← Back to branch summary

~ubuntu-branches/ubuntu/precise/gnuradio/precise

« back to all changes in this revision

Viewing changes to mblock/src/scheme/gnuradio/compile-mbh.scm

  • Committer: Bazaar Package Importer
  • Author(s): Kamal Mostafa
  • Date: 2010-03-13 07:46:01 UTC
  • mfrom: (2.1.2 sid)
  • Revision ID: james.westby@ubuntu.com-20100313074601-zjsa893a87bozyh7
Tags: 3.2.2.dfsg-1ubuntu1
https://launchpad.net/bugs/260406
* Fix build for Ubuntu lucid (LP: #260406)
  - add binary package dep for libusrp0, libusrp2-0: adduser
  - debian/rules clean: remove pre-built Qt moc files

Show diffs side-by-side

added added

removed removed

Lines of Context:
mblock/src/scheme/gnuradio/compile-mbh.scm
 
1
#!/usr/bin/guile \
 
2
-e main -s
 
3
!#
 
4
;; -*-scheme-*-
 
5
;;
 
6
;; Copyright 2007,2008 Free Software Foundation, Inc.
 
7
;; 
 
8
;; This file is part of GNU Radio
 
9
;; 
 
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)
 
13
;; any later version.
 
14
;; 
 
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.
 
19
;; 
 
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.
 
23
;;
 
24
 
 
25
;; usage: compile-mbh <input-file> <output-file>
 
26
 
 
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))
 
33
 
 
34
(debug-enable 'backtrace)
 
35
 
 
36
;; ----------------------------------------------------------------
 
37
 
 
38
(define (main args)
 
39
 
 
40
  (define (usage)
 
41
    (format 0 "usage: ~a input-file output-file~%" (car args)))
 
42
 
 
43
  (when (not (= (length args) 3))
 
44
        (usage)
 
45
        (exit 1))
 
46
      
 
47
  (let ((input-filename (cadr args))
 
48
        (output-filename (caddr args)))
 
49
      (if (compile-mbh-file input-filename output-filename)
 
50
          (exit 0)
 
51
          (exit 1))))
 
52
 
 
53
 
 
54
;; ----------------------------------------------------------------
 
55
;; constructor and accessors for protocol-class
 
56
 
 
57
(define %protocol-class-tag (string->symbol "[PROTOCOL-CLASS-TAG]"))
 
58
 
 
59
(define (make-protocol-class name incoming outgoing)
 
60
  (vector %protocol-class-tag name incoming outgoing))
 
61
 
 
62
(define (protocol-class? obj)
 
63
  (and (vector? obj) (eq? %protocol-class-tag (vector-ref obj 0))))
 
64
 
 
65
(define (protocol-class-name pc)
 
66
  (vector-ref pc 1))
 
67
 
 
68
(define (protocol-class-incoming pc)
 
69
  (vector-ref pc 2))
 
70
 
 
71
(define (protocol-class-outgoing pc)
 
72
  (vector-ref pc 3))
 
73
 
 
74
 
 
75
;; ----------------------------------------------------------------
 
76
 
 
77
(define (syntax-error msg e)
 
78
  (throw 'syntax-error msg e))
 
79
 
 
80
(define (unrecognized-form form)
 
81
  (syntax-error "Unrecognized form" form))
 
82
 
 
83
 
 
84
(define (mbh-chk-length= e y n)
 
85
  (cond ((and (null? y)(zero? n))
 
86
         #f)
 
87
        ((null? y)
 
88
         (syntax-error "Expression has too few subexpressions" e))
 
89
        ((atom? y)
 
90
         (syntax-error (if (atom? e)
 
91
                           "List expected"
 
92
                           "Expression ends with `dotted' atom")
 
93
                       e))
 
94
        ((zero? n)
 
95
         (syntax-error "Expression has too many subexpressions" e))
 
96
        (else
 
97
          (mbh-chk-length= e (cdr y) (- n 1)))))
 
98
 
 
99
(define (mbh-chk-length>= e y n)
 
100
  (cond ((and (null? y)(< n 1))
 
101
         #f)
 
102
        ((atom? y)
 
103
         (mbh-chk-length= e y -1))
 
104
        (else
 
105
          (mbh-chk-length>= e (cdr y) (- n 1)))))
 
106
 
 
107
 
 
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)))
 
111
 
 
112
    (letrec
 
113
      ((protocol-classes '())           ; alist
 
114
 
 
115
       (lookup-protocol-class           ; returns protocol-class or #f
 
116
        (lambda (name)
 
117
          (cond ((assq name protocol-classes) => cdr)
 
118
                (else #f))))
 
119
 
 
120
       (register-protocol-class
 
121
        (lambda (pc)
 
122
          (set! protocol-classes (acons (protocol-class-name pc)
 
123
                                          pc protocol-classes))
 
124
          pc))
 
125
                                          
 
126
       (parse-top-level-form
 
127
        (lambda (form)
 
128
          (mbh-chk-length>= form form 1)
 
129
          (case (car form)
 
130
            ((define-protocol-class) (parse-define-protocol-class form))
 
131
            (else (syntax-error form)))))
 
132
 
 
133
       (parse-define-protocol-class
 
134
        (lambda (form)               
 
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))
 
141
                  (incoming '())
 
142
                  (outgoing '()))
 
143
              (if (lookup-protocol-class name)
 
144
                  (syntax-error "Duplicate protocol-class name" name))
 
145
              (for-each
 
146
               (lambda (sub-form)
 
147
                 (mbh-chk-length>= sub-form sub-form 1)
 
148
                 (case (car sub-form)
 
149
                   ((:include)
 
150
                    (mbh-chk-length>= sub-form sub-form 2)
 
151
                    (cond ((lookup-protocol-class (cadr sub-form)) =>
 
152
                           (lambda (pc)
 
153
                             (set! incoming (append incoming (protocol-class-incoming pc)))
 
154
                             (set! outgoing (append outgoing (protocol-class-outgoing pc)))))
 
155
                          (else
 
156
                           (syntax-error "Unknown protocol-class-name" (cadr sub-form)))))
 
157
                   ((:incoming)
 
158
                    (set! incoming (append incoming (cdr sub-form))))
 
159
                   ((:outgoing)
 
160
                    (set! outgoing (append outgoing (cdr sub-form))))
 
161
                   (else
 
162
                    (unrecognized-form (car sub-form)))))
 
163
               (cddr form))
 
164
              
 
165
              (register-protocol-class (make-protocol-class name incoming outgoing)))))
 
166
 
 
167
       ) ; end of bindings
 
168
 
 
169
      (for-each-in-file i-port parse-top-level-form)
 
170
 
 
171
      ;; generate the output here...
 
172
 
 
173
      (letrec ((classes (map cdr protocol-classes))
 
174
               (so-stream (make-serial-output-stream))
 
175
               (format-output-for-c++
 
176
                (lambda (output)
 
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 "//~%")
 
182
 
 
183
                  (format o-port "#include <mblock/protocol_class.h>~%")
 
184
                  (format o-port "#include <unistd.h>~%")
 
185
                  (format o-port
 
186
                          "static const char~%protocol_class_init_data[~d] = {~%  "
 
187
                          (length output))
 
188
 
 
189
                  (do ((lst output (cdr lst))
 
190
                       (i 0 (+ i 1)))
 
191
                      ((null? lst) #t)
 
192
                    (format o-port "~a, " (car lst))
 
193
                    (when (= 15 (modulo i 16))
 
194
                          (format o-port "~%  ")))
 
195
 
 
196
                  (format o-port "~&};~%")
 
197
                  (format o-port "static mb_protocol_class_init _init_(protocol_class_init_data, sizeof(protocol_class_init_data));~%")
 
198
                  )))
 
199
                  
 
200
                  
 
201
        (map (lambda (pc)
 
202
               (let ((obj-to-dump
 
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
 
208
                            ))) 
 
209
                 ;;(pretty-print obj-to-dump)  
 
210
                 (pmt-serialize obj-to-dump (so-stream 'put-byte))))
 
211
             classes)
 
212
 
 
213
        (format-output-for-c++ ((so-stream 'get-output)))
 
214
 
 
215
        #t))))
 
216
 
 
217
 
 
218
(define (make-serial-output-stream)
 
219
  (letrec ((output '())
 
220
           (put-byte
 
221
            (lambda (byte)
 
222
              (set! output (cons byte output))))
 
223
           (get-output
 
224
            (lambda ()
 
225
              (reverse output))))
 
226
    (lambda (key)
 
227
      (case key
 
228
        ((put-byte) put-byte)
 
229
        ((get-output) get-output)
 
230
        (else (error "Unknown key" key))))))
 
231