Commits

Pjotr Kourzanov committed add0b01

use R5RS macros everywhere

  • Participants
  • Parent commits f307585

Comments (0)

Files changed (1)

File src/sequel/beseq.nw

 (labels ([find-unconnected (all connected)
 		(let loop ([x (cdr all)]
 			   [res '()])
-;		    (and (pair? x) (printf "x=~s~n" (car x)))
-;		    (and (pair? x) (printf "i=~s~n" (cdr connected)))
-		    (cond
-		       ([null? x] res)
-		       (else (if (assoc (car x) (cdr connected))
-				 (loop (cdr x) res)
-				 (loop (cdr x) (cons (copy-port (cadar x) (caar x)) res)))))
+		   ;(and (pair? x) (printf "x=~s~n" (car x)))
+		   ;(and (pair? x) (printf "i=~s~n" (cdr connected)))
+		   (cond
+		      ([null? x] res)
+		      (else (if (assoc (car x) (cdr connected))
+				(loop (cdr x) res)
+				(loop (cdr x) (cons (copy-port (cadar x) (caar x)) res)))))
 		    )])
 	    (append (find-unconnected all-in incoming)
 		    (find-unconnected all-out outgoing))
 	  )
 <<process>>=
 (define (gxf:collapsed-ports sxml)
-;   (pp sxml)
+   ;(pp sxml)
    (let ([r (pre-post-order sxml
 		   `((*TOP* *macro* 	. ,(lambda top (list
 					`[(outgoing ,@((sxpath '(gxf stream edge from-node)) top))
 		     ; Retrieve all type nodes, one for each instance node (so, duplicates are possible)
 		     (nodeinst *macro*  . ,(lambda (t . x)
 					`(nodetype ,@(map (lambda (ni)
-					    (list (car ((sxpath '(id *text*)) ni))
+					    (list (X(id) ni)
 						  (car ((sxpath "gxf/node[id=$n]") sxml
 							   `[(n . ,(cadr (cadddr ni)))]))))
 								x))))
 		     (@ *preorder*  	. ,Id)
 		     (*text*  		. ,Unmeta)
 		     (*default*  	. ,Id)))])
-;      (pp r)
+      ;(pp r)
       (let ([outgoing (caar r)]
 	    [incoming (cadar r)]
 	    [all-in (caadr r)]
   data-flow analysis.
 
 <<process>>=
-(define-macro (gen-getter s)
-   `(define (,(symbol-append 'get- s) p)
-      (car ((sxpath (,s *text*)) p))))
-
-(define-macro (gen-getter-num s)
-   `(define (,(symbol-append 'get- s) p)
-      (string->number (car ((sxpath (,s *text)) p)))))
-
-(define-macro (gen-predicate s)
-   (eval `(begin
-	     (define (,(symbol-append 'is- s) p)
-		(pair? ((sxpath '(,s)) p)))
-	     (define (,(symbol-append 'is-not- s) p)
-		(null? ((sxpath '(,s)) p))))))
-
-(gen-predicate const)
-(gen-predicate static)
-(gen-predicate restrict)
-(gen-getter type)
-(gen-getter-num size)
+(define-syntax helper (syntax-rules ()
+      ([_ (r ...)] (eval `(begin r ...)))
+      ([_ (r ...) t x rest ...] (helper (r ... ,@(geng t x)) rest ...))
+      ))
+(define-syntax geng
+   (syntax-rules (^ % ?)
+      ([_ ^ s] `((define (,(symbol-append `get- `s) p)
+		(car ((sxpath `(s *text*)) p)))))
+      ([_ % s] `((define (,(symbol-append `get- `s) p)
+		   (string->number (car ((sxpath `(s *text*)) p))))))
+      ([_ ? s] `((define (,(symbol-append `is- `s) p)
+		    (pair? ((sxpath `(s)) p)))
+		 (define (,(symbol-append `is-not- `s) p)
+		    (null? ((sxpath `(s)) p)))))
+      ([_ t s rest ...] (helper () t s rest ...))
+       ))
+(geng ? const ? static ? restrict ^ type % size)
 
 <<process>>=
-(define (gxf:activate n in)
+(define (gxf:activate n in #!optional edge-names)
    (forall [(n <- ((sxpath "gxf/node[id=$n]/node") in
 		     `([n . ,((sxpath "gxf/node[id=$n]/stereo-type/text()") in
-			`([n . ,(symbol->string n)]))])))]
-	   do (forall [(p <- ((sxpath '(port)) n))]
-		      do (and (is-const p) (pp p)))
-	     ))
+			`([n . ,($ n)]))])))]
+    do (forall [(p <- ((sxpath '(port)) n))]
+	where (is-const p)
+	do ;(pp p)
+	   (out (X(@(id)) p))
+	)
+    ))
+
+@  This code snippet outputs the variable definition for the buffer, and returns
+   an association between the edge and corresponding variable name.
+
+<<declare internal buffers>>=
+(forall [(ed <- edges)
+	 (x  <- (array->list mb))]
+ return (let ([name (@ ($caar ed) "_" ($caadr ed))])
+    (begin (out "char" name
+		(@ "[" (%car x) "]")
+		";")
+	  (list name ed))
+	  ))
+
+<<activate static schedule>>=
+(forall [(x <- cy)] 
+ do (labels ([find-activation (v a)
+		(do ((i 0 (+ 1 i)))
+		    [(or (positive? (vector-ref v i))
+			 (>= i (vector-length v)))
+		     (list-ref a i)])
+			      ])
+       (let* ([v (cddr x)]
+	      [n (find-activation v actors)])
+	  ;(gxf:activate n in edge-names)
+	  (out ($ n) "(" ");" )
+	  )))
 
 <<process>>=
 (define (gxf:collapse-code in)
 	  [r repvec])
       (begin
 	 ;(pp ll)
-	 ;(pp edges)
+	 ;(debug edges)
 	 (if (not (vector:check r positive?))
 	     (error "simulate" "data-flow graph is inconsistent" r)
 	     #t;(printf "r=~s~nb=~s~n" r buf)
 	 (let* ([sr (simulate G (vector->array buf '#(0) (incidence:edges G) 1)  '())]
 		[mb (car sr)]
 		[cy (cadr sr)])
-	 (pp (array->vector mb))
-	 (pp (list->vector actors))
+	 (debug (array->vector mb))
+	 (debug (list->vector actors))
 	 ;(pp cy)
 	 
 	 (with-output-to-string (lambda ()
-	   (begin
-	      (forall [(ed <- edges)
-		       (x  <- (array->list mb))]
-		do (begin
-		      (out "char" (@ ($ (caar ed)) "_" ($ (caadr ed)))
-			   (@ "[" (% (car x)) "]") ";")
-		      ))
-	      (forall [(x <- cy)] 
-		      do (labels ([find-activation (v a)
-					(do ([i 0 (+ 1 i)])
-					    [(or (positive? (vector-ref v i))
-						 (>= i (vector-length v))) (list-ref a i)])
-						])
-			      (let* ([v (cddr x)]
-				     [n (find-activation v actors)])
-				 ;(gxf:activate n in)
-				 (out (symbol->string n) "(" ");" )
-				 )))
+	   (let ([edge-names <<declare internal buffers>>])
+	      <<activate static schedule>>
 	      )))
 	 ))))
 
    `((id ,id)
      (xlink:label ,id)))
 
-@ Copy a \mac{GXF} port structure, with all its formal contents (see the \mac{DTD})
-
-<<Miscellaneous>>=
-(define (copy-port p prefix)
-   `(port (@ (xlink:type "resource")
-	     ,@(gxf:labels (@ prefix ":" (car ((sxpath '(id *text*)) p)))))
-	  ,@((sxpath "id|type|size|calltype|const|static|restrict") p)
-	  ))
-
-
 @ Nice shortcut for XPath expressions...
 
 <<Miscellaneous>>=
-(define (sxpath/link e)
-	(sxpath/c e Namespaces))
+(define (sxpath/link e) (sxpath/c e Namespaces))
 
 @ Handy shortcuts for [[pre-port-order]]...
 
 
 <<Miscellaneous>>=
 (define (lfold> f id l)
-   (labels ([tail-recursion (l r)
+   (labels ([lfold>helper (l r)
 		      (cond
 			 ([null? l]
 			  r)
 			 ([pair? l]
-			  (tail-recursion (cdr l) (f (car l) r))))])
-      (tail-recursion l id)))
+			  (lfold>helper (cdr l) (f (car l) r))))])
+      (lfold>helper l id)))
 
 (define (lfold< f id l) (lfold> (lambda (x y) (f y x)) id l))
 
 
 <<Miscellaneous>>=
 (define (filter-map-splice p l)
-   (labels ([tail-recursion (p l res)
+   (labels ([filter-map-splice-helper (p l res)
 			    (cond
 			       ([null? l] res)
 			       ([pair? l] (let loop ([v (p (car l))]
 						     [r res])
 					     (cond
 						([or (not v) (null? v)]
-						 (tail-recursion p (cdr l) r))
+						 (filter-map-splice-helper p (cdr l) r))
 						([pair? v]
 						 (loop (cdr v) (cons (car v) r)))
 						(else
 						 (loop '() (cons v r))))))
 			       (else (error "filter-map-splice" "unexpected object" l)))])
-      (tail-recursion p l '())))
+      (filter-map-splice-helper p l '())))
 
 @ A handy macro to retrieve an argument [[ind]] from a list of [[args]], or use a default value [[def]] 
   ([["*"]] if that is not specified)
 @ Handy replacement macro for [[for-each]], [[filter]] and [[map]].
 
 <<Miscellaneous>>=
-(define (for-all l p) (for-each p l))
+(define-syntax forall
+   (syntax-rules (<- do where with return)
+      ((_ (vars ...) <- (l ...) do a ...)
+       (for-each (lambda (vars ...) a ...) l ...))
+      ((_ ((var <- l) ...) do a ...)
+       (for-each (lambda (var ...) a ...) l ...))
 
-(define-syntax forall
-   (syntax-rules (<- do where)
-      ([_ ((var <- l) ...) do a ...] (for-each (lambda (var ...) a ...) l ...))
-      ([_ ((var <- l) ...) where p ...] (filter (lambda (var ...) p ...) l ...))
-      ([_ ((var <- l) ...)] (map (lambda (var ...) (list var ...)) l ...))
+      ((_ (vars ...) <- (l ...) where (p ...) do a ...)
+       (for-each (lambda (vars ...) (if (p ...) (begin a ...)
+					#f)) l ...))
+      ((_ ((var <- l) ...) where (p ...) do a ...)
+       (for-each (lambda (var ...) (if (p ...) (begin a ...)
+					#f)) l ...))
+
+      ((_ (vars ...) <- (l ...) with (p ...))
+       (filter-map (lambda (vars ...) (if (p ...) (list vars ...)
+					  #f)) l ...))
+      ((_ ((var <- l) ...) with (p ...))
+       (filter-map (lambda (var ...) (if (p ...) (list var ...)
+					 #f)) l ...))
+      
+      
+      ((_ (vars ...) <- (l ...) where p ...)
+       (filter (lambda (vars ...) p ...) l ...))
+      ((_ ((var <- l) ...) where p ...)
+       (filter (lambda (var ...) p ...) l ...))
+
+      ((_ (vars ...) <- (l ...) return f ...)
+       (map (lambda (vars ...) f ...) l ...))
+      ((_ ((var <- l) ...) return f ...)
+       (map (lambda (var ...) f ...) l ...))
+      
+      ((_ (vars ...) <- (l ...))
+       (map (lambda (vars ...) (list vars ...)) l ...))
+      ((_ ((var <- l) ...))
+       (map (lambda (var ...) (list var ...)) l ...))
       ))
 
+
 @ A small printer.
 
 <<Miscellaneous>>=
 (define (out . l)
    (let ([first #t])
       (forall [(x <- l)] 
-	   do (begin
-	      (or first (display " "))
-	      (set! first #f)
-	      (display x))
+       do (begin
+	     (or first (display " "))
+	     (set! first #f)
+	     (display x))
 	   ))
       (newline))
 
+@ Functional composition functor
+
+<<Miscellaneous>>=
+(define (compose2 f g)
+   (lambda x
+      (apply g (list (apply f x)))))
+
+(define (compose . fs)
+  (letrec ([helper (lambda (r fs)
+      (if [pair? fs]
+	  (helper (compose2 r (car fs)) (cdr fs))
+	  r))])
+    (helper Identity fs)))
+
 @ Shortcuts for [[string-append]], [[number->string]] and [[symbol->string]]
 
 <<Miscellaneous>>=
 (define % number->string)
 (define $ symbol->string)
 
+(define %car (compose car %))
+(define $caar (compose caar $))
+(define $caadr (compose caadr $))
+
+(define-syntax X
+   (syntax-rules ()
+      ([_ (x ...) t] (car ((sxpath '(x ... *text*)) t)))))
+
+(define-syntax X%
+   (syntax-rules ()
+      ([_ (x ...) t] (string->number (X (x ...) t)))))
+
+(define-syntax X$
+   (syntax-rules ()
+      ([_ (x ...) t] (string->symbol (X (x ...) t)))))
+
+@ Copy a \mac{GXF} port structure, with all its formal contents (see the \mac{DTD})
+
+<<Miscellaneous>>=
+(define (copy-port p prefix)
+   `(port (@ (xlink:type "resource")
+	     ,@(gxf:labels (@ prefix ":" (X(id) p))))
+	  ,@((sxpath "id|type|size|calltype|const|static|restrict") p)
+	  ))
+
+
+@ A debugging facility
+
+<<Miscellaneous>>=
+(define-syntax debug
+   (syntax-rules ()
+      ([_ term] (begin
+		   (display `term)
+		   (display ": ")
+		   (pp term)))))
+
 @ \subsection{Trashbin}\label{ssec:trash}
 
 <<Trash>>=
 		  (pair? ((sxpath ,(symbol->string s)) p))
 		  ) (interaction-environment))) '(const static restrict))
 
+(define (for-all l p) (for-each p l))
+(define-syntax @forall
+   (syntax-rules (<- do where)
+      ([_ ((var <- l) ...) do a ...] (for-each (lambda (var ...) a ...) l ...))
+      ([_ ((var <- l) ...) where p ...] (filter (lambda (var ...) p ...) l ...))
+      ([_ ((var <- l) ...)] (map (lambda (var ...) (list var ...)) l ...))
+      ))
+(define-macro (gen-getter s)
+   `(define (,(symbol-append 'get- s) p)
+      (car ((sxpath (,s *text*)) p))))
+
+(define-macro (gen-getter-num s)
+   `(define (,(symbol-append 'get- s) p)
+      (string->number (car ((sxpath (,s *text)) p)))))
+
+(define-macro (gen-predicate s)
+   (eval `(begin
+	     (define (,(symbol-append 'is- s) p)
+		(pair? ((sxpath '(,s)) p)))
+	     (define (,(symbol-append 'is-not- s) p)
+		(null? ((sxpath '(,s)) p))))))
+
+(gen-predicate const)
+(gen-predicate static)
+(gen-predicate restrict)
+(gen-getter type)
+(gen-getter-num size)
+
 @ % Emacs trickery
 %%% Local Variables:
 %%% mode: latex