[Commit-gnuradio] r4827 - gnuradio/branches/developers/eb/ibu/mblock/src/tools

[eb]

Author: eb
Date: 2007-03-30 19:16:43 -0600 (Fri, 30 Mar 2007)
New Revision: 4827

Added:
   gnuradio/branches/developers/eb/ibu/mblock/src/tools/compile-mbh.scm
Log:
work-in-progress on mbh compiler

Added: gnuradio/branches/developers/eb/ibu/mblock/src/tools/compile-mbh.scm
===================================================================
--- gnuradio/branches/developers/eb/ibu/mblock/src/tools/compile-mbh.scm        
                        (rev 0)
+++ gnuradio/branches/developers/eb/ibu/mblock/src/tools/compile-mbh.scm        
2007-03-31 01:16:43 UTC (rev 4827)
@@ -0,0 +1,200 @@
+#!/usr/bin/guile \
+-e main -s
+!#
+;; -*-scheme-*-
+;;
+;; Copyright 2007 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 2, 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 <input-file> <output-file>
+
+(use-modules (ice-9 getopt-long))
+(use-modules (ice-9 format))
+(use-modules (ice-9 pretty-print))
+;(use-modules (ice-9 slib))
+
+(debug-enable 'backtrace)
+
+(define (atom? obj)
+  (not (pair? obj)))
+
+(defmacro when (pred . body)
+  `(if ,pred (begin ,@body) #f))
+
+(defmacro unless (pred . body)
+  `(if (not ,pred) (begin ,@body) #f))
+
+;; ----------------------------------------------------------------
+
+(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...
+        
+      (pretty-print (map cdr protocol-classes) o-port)
+
+      #t)))
+
+
+(define (for-each-in-file file f)
+  (let ((port (if (port? file)
+                 file
+                 (open-input-file file))))
+    (letrec
+     ((loop
+       (lambda (port form)
+        (cond ((eof-object? form)
+               (when (not (eq? port file))
+                     (close-input-port port))
+               #t)
+              (else
+               (f form)
+               (set! form #f)          ; for GC
+               (loop port (read port)))))))
+     (loop port (read port)))))


Property changes on: 
gnuradio/branches/developers/eb/ibu/mblock/src/tools/compile-mbh.scm
___________________________________________________________________
Name: svn:executable
   + *