git.gag.com Git - debian/gnuradio/blob - 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