X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=mblock%2Fsrc%2Fscheme%2Fgnuradio%2Fcompile-mbh.scm;fp=mblock%2Fsrc%2Fscheme%2Fgnuradio%2Fcompile-mbh.scm;h=30085340f90c77900fbcf67b5020f2690ba61bf8;hb=ea29b08aeb54227e6628f655ccfdb96fe4d8c378;hp=0000000000000000000000000000000000000000;hpb=09a1e803a9e6587c78d20cdf16891e5295874668;p=debian%2Fgnuradio diff --git a/mblock/src/scheme/gnuradio/compile-mbh.scm b/mblock/src/scheme/gnuradio/compile-mbh.scm new file mode 100755 index 00000000..30085340 --- /dev/null +++ b/mblock/src/scheme/gnuradio/compile-mbh.scm @@ -0,0 +1,231 @@ +#!/usr/bin/guile \ +-e main -s +!# +;; -*-scheme-*- +;; +;; Copyright 2007,2008 Free Software Foundation, Inc. +;; +;; This file is part of GNU Radio +;; +;; GNU Radio is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; GNU Radio is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with this program; if not, write to the Free Software Foundation, Inc., +;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +;; + +;; usage: compile-mbh + +(use-modules (ice-9 getopt-long)) +(use-modules (ice-9 format)) +(use-modules (ice-9 pretty-print)) +;(use-modules (ice-9 slib)) +(use-modules (gnuradio pmt-serialize)) +(use-modules (gnuradio macros-etc)) + +(debug-enable 'backtrace) + +;; ---------------------------------------------------------------- + +(define (main args) + + (define (usage) + (format 0 "usage: ~a input-file output-file~%" (car args))) + + (when (not (= (length args) 3)) + (usage) + (exit 1)) + + (let ((input-filename (cadr args)) + (output-filename (caddr args))) + (if (compile-mbh-file input-filename output-filename) + (exit 0) + (exit 1)))) + + +;; ---------------------------------------------------------------- +;; constructor and accessors for protocol-class + +(define %protocol-class-tag (string->symbol "[PROTOCOL-CLASS-TAG]")) + +(define (make-protocol-class name incoming outgoing) + (vector %protocol-class-tag name incoming outgoing)) + +(define (protocol-class? obj) + (and (vector? obj) (eq? %protocol-class-tag (vector-ref obj 0)))) + +(define (protocol-class-name pc) + (vector-ref pc 1)) + +(define (protocol-class-incoming pc) + (vector-ref pc 2)) + +(define (protocol-class-outgoing pc) + (vector-ref pc 3)) + + +;; ---------------------------------------------------------------- + +(define (syntax-error msg e) + (throw 'syntax-error msg e)) + +(define (unrecognized-form form) + (syntax-error "Unrecognized form" form)) + + +(define (mbh-chk-length= e y n) + (cond ((and (null? y)(zero? n)) + #f) + ((null? y) + (syntax-error "Expression has too few subexpressions" e)) + ((atom? y) + (syntax-error (if (atom? e) + "List expected" + "Expression ends with `dotted' atom") + e)) + ((zero? n) + (syntax-error "Expression has too many subexpressions" e)) + (else + (mbh-chk-length= e (cdr y) (- n 1))))) + +(define (mbh-chk-length>= e y n) + (cond ((and (null? y)(< n 1)) + #f) + ((atom? y) + (mbh-chk-length= e y -1)) + (else + (mbh-chk-length>= e (cdr y) (- n 1))))) + + +(define (compile-mbh-file input-filename output-filename) + (let ((i-port (open-input-file input-filename)) + (o-port (open-output-file output-filename))) + + (letrec + ((protocol-classes '()) ; alist + + (lookup-protocol-class ; returns protocol-class or #f + (lambda (name) + (cond ((assq name protocol-classes) => cdr) + (else #f)))) + + (register-protocol-class + (lambda (pc) + (set! protocol-classes (acons (protocol-class-name pc) + pc protocol-classes)) + pc)) + + (parse-top-level-form + (lambda (form) + (mbh-chk-length>= form form 1) + (case (car form) + ((define-protocol-class) (parse-define-protocol-class form)) + (else (syntax-error form))))) + + (parse-define-protocol-class + (lambda (form) + (mbh-chk-length>= form form 2) + ;; form => (define-protocol-class name + ;; (:include protocol-class-name) + ;; (:incoming list-of-msgs) + ;; (:outgoing list-of-msgs)) + (let ((name (cadr form)) + (incoming '()) + (outgoing '())) + (if (lookup-protocol-class name) + (syntax-error "Duplicate protocol-class name" name)) + (for-each + (lambda (sub-form) + (mbh-chk-length>= sub-form sub-form 1) + (case (car sub-form) + ((:include) + (mbh-chk-length>= sub-form sub-form 2) + (cond ((lookup-protocol-class (cadr sub-form)) => + (lambda (pc) + (set! incoming (append incoming (protocol-class-incoming pc))) + (set! outgoing (append outgoing (protocol-class-outgoing pc))))) + (else + (syntax-error "Unknown protocol-class-name" (cadr sub-form))))) + ((:incoming) + (set! incoming (append incoming (cdr sub-form)))) + ((:outgoing) + (set! outgoing (append outgoing (cdr sub-form)))) + (else + (unrecognized-form (car sub-form))))) + (cddr form)) + + (register-protocol-class (make-protocol-class name incoming outgoing))))) + + ) ; end of bindings + + (for-each-in-file i-port parse-top-level-form) + + ;; generate the output here... + + (letrec ((classes (map cdr protocol-classes)) + (so-stream (make-serial-output-stream)) + (format-output-for-c++ + (lambda (output) + (format o-port "//~%") + (format o-port "// Machine generated by compile-mbh from ~a~%" input-filename) + (format o-port "//~%") + (format o-port "// protocol-classes: ~{~a ~}~%" (map car protocol-classes)) + (format o-port "//~%") + + (format o-port "#include ~%") + (format o-port "#include ~%") + (format o-port + "static const char~%protocol_class_init_data[~d] = {~% " + (length output)) + + (do ((lst output (cdr lst)) + (i 0 (+ i 1))) + ((null? lst) #t) + (format o-port "~a, " (car lst)) + (when (= 15 (modulo i 16)) + (format o-port "~% "))) + + (format o-port "~&};~%") + (format o-port "static mb_protocol_class_init _init_(protocol_class_init_data, sizeof(protocol_class_init_data));~%") + ))) + + + (map (lambda (pc) + (let ((obj-to-dump + (list (protocol-class-name pc) ; class name + (map car (protocol-class-incoming pc)) ; incoming msg names + (map car (protocol-class-outgoing pc)) ; outgoing msg names + ;;(protocol-class-incoming pc) ; full incoming msg descriptions + ;;(protocol-class-outgoing pc) ; full outgoing msg descriptions + ))) + ;;(pretty-print obj-to-dump) + (pmt-serialize obj-to-dump (so-stream 'put-byte)))) + classes) + + (format-output-for-c++ ((so-stream 'get-output))) + + #t)))) + + +(define (make-serial-output-stream) + (letrec ((output '()) + (put-byte + (lambda (byte) + (set! output (cons byte output)))) + (get-output + (lambda () + (reverse output)))) + (lambda (key) + (case key + ((put-byte) put-byte) + ((get-output) get-output) + (else (error "Unknown key" key)))))) +