6 ;; Copyright 2007,2008 Free Software Foundation, Inc.
8 ;; This file is part of GNU Radio
10 ;; GNU Radio is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 3, or (at your option)
15 ;; GNU Radio is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License along
21 ;; with this program; if not, write to the Free Software Foundation, Inc.,
22 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
25 ;; usage: compile-mbh <input-file> <output-file>
27 (use-modules (ice-9 getopt-long))
28 (use-modules (ice-9 format))
29 (use-modules (ice-9 pretty-print))
30 ;(use-modules (ice-9 slib))
31 (use-modules (gnuradio pmt-serialize))
32 (use-modules (gnuradio macros-etc))
34 (debug-enable 'backtrace)
36 ;; ----------------------------------------------------------------
41 (format 0 "usage: ~a input-file output-file~%" (car args)))
43 (when (not (= (length args) 3))
47 (let ((input-filename (cadr args))
48 (output-filename (caddr args)))
49 (if (compile-mbh-file input-filename output-filename)
54 ;; ----------------------------------------------------------------
55 ;; constructor and accessors for protocol-class
57 (define %protocol-class-tag (string->symbol "[PROTOCOL-CLASS-TAG]"))
59 (define (make-protocol-class name incoming outgoing)
60 (vector %protocol-class-tag name incoming outgoing))
62 (define (protocol-class? obj)
63 (and (vector? obj) (eq? %protocol-class-tag (vector-ref obj 0))))
65 (define (protocol-class-name pc)
68 (define (protocol-class-incoming pc)
71 (define (protocol-class-outgoing pc)
75 ;; ----------------------------------------------------------------
77 (define (syntax-error msg e)
78 (throw 'syntax-error msg e))
80 (define (unrecognized-form form)
81 (syntax-error "Unrecognized form" form))
84 (define (mbh-chk-length= e y n)
85 (cond ((and (null? y)(zero? n))
88 (syntax-error "Expression has too few subexpressions" e))
90 (syntax-error (if (atom? e)
92 "Expression ends with `dotted' atom")
95 (syntax-error "Expression has too many subexpressions" e))
97 (mbh-chk-length= e (cdr y) (- n 1)))))
99 (define (mbh-chk-length>= e y n)
100 (cond ((and (null? y)(< n 1))
103 (mbh-chk-length= e y -1))
105 (mbh-chk-length>= e (cdr y) (- n 1)))))
108 (define (compile-mbh-file input-filename output-filename)
109 (let ((i-port (open-input-file input-filename))
110 (o-port (open-output-file output-filename)))
113 ((protocol-classes '()) ; alist
115 (lookup-protocol-class ; returns protocol-class or #f
117 (cond ((assq name protocol-classes) => cdr)
120 (register-protocol-class
122 (set! protocol-classes (acons (protocol-class-name pc)
123 pc protocol-classes))
126 (parse-top-level-form
128 (mbh-chk-length>= form form 1)
130 ((define-protocol-class) (parse-define-protocol-class form))
131 (else (syntax-error form)))))
133 (parse-define-protocol-class
135 (mbh-chk-length>= form form 2)
136 ;; form => (define-protocol-class name
137 ;; (:include protocol-class-name)
138 ;; (:incoming list-of-msgs)
139 ;; (:outgoing list-of-msgs))
140 (let ((name (cadr form))
143 (if (lookup-protocol-class name)
144 (syntax-error "Duplicate protocol-class name" name))
147 (mbh-chk-length>= sub-form sub-form 1)
150 (mbh-chk-length>= sub-form sub-form 2)
151 (cond ((lookup-protocol-class (cadr sub-form)) =>
153 (set! incoming (append incoming (protocol-class-incoming pc)))
154 (set! outgoing (append outgoing (protocol-class-outgoing pc)))))
156 (syntax-error "Unknown protocol-class-name" (cadr sub-form)))))
158 (set! incoming (append incoming (cdr sub-form))))
160 (set! outgoing (append outgoing (cdr sub-form))))
162 (unrecognized-form (car sub-form)))))
165 (register-protocol-class (make-protocol-class name incoming outgoing)))))
169 (for-each-in-file i-port parse-top-level-form)
171 ;; generate the output here...
173 (letrec ((classes (map cdr protocol-classes))
174 (so-stream (make-serial-output-stream))
175 (format-output-for-c++
177 (format o-port "//~%")
178 (format o-port "// Machine generated by compile-mbh from ~a~%" input-filename)
179 (format o-port "//~%")
180 (format o-port "// protocol-classes: ~{~a ~}~%" (map car protocol-classes))
181 (format o-port "//~%")
183 (format o-port "#include <mblock/protocol_class.h>~%")
184 (format o-port "#include <unistd.h>~%")
186 "static const char~%protocol_class_init_data[~d] = {~% "
189 (do ((lst output (cdr lst))
192 (format o-port "~a, " (car lst))
193 (when (= 15 (modulo i 16))
194 (format o-port "~% ")))
196 (format o-port "~&};~%")
197 (format o-port "static mb_protocol_class_init _init_(protocol_class_init_data, sizeof(protocol_class_init_data));~%")
203 (list (protocol-class-name pc) ; class name
204 (map car (protocol-class-incoming pc)) ; incoming msg names
205 (map car (protocol-class-outgoing pc)) ; outgoing msg names
206 ;;(protocol-class-incoming pc) ; full incoming msg descriptions
207 ;;(protocol-class-outgoing pc) ; full outgoing msg descriptions
209 ;;(pretty-print obj-to-dump)
210 (pmt-serialize obj-to-dump (so-stream 'put-byte))))
213 (format-output-for-c++ ((so-stream 'get-output)))
218 (define (make-serial-output-stream)
219 (letrec ((output '())
222 (set! output (cons byte output))))
228 ((put-byte) put-byte)
229 ((get-output) get-output)
230 (else (error "Unknown key" key))))))