[(Almost working) Reimplementation of scsh process notation
clinton@unknownlamer.org**20100329202511
 Ignore-this: df44f1ff26ad671876a4ec938ca24463
 * Mostly a complete rewrite (the docs on the syntax were more
   useful than the code--none was reused!)
 * Expansion of forms work--compiling does not since I have yet to
   implement all of the helper functions required
] hunk ./module/scsh/syntax-helpers.scm 8
+;;; 'Ported' (or, perhaps, more or less a total rewrite) to
+;;; syntax-case as part of Guile Facade
+;;; Copyright (c) 2010 Clinton Ebadi
+
+(define-module (scsh syntax-helpers)
+  #:use-module (scsh utilities)
+  #:export (expand-process-form
+	    define-simple-syntax))
+
hunk ./module/scsh/syntax-helpers.scm 22
-(define (name? thing)
-  (or (symbol? thing)
-      (generated? thing)))
+;;; name? -> identifier?
+;; (define (name? thing)
+;;   (or (symbol? thing)
+;;       (generated? thing)))
hunk ./module/scsh/syntax-helpers.scm 31
-;;; Some process forms and redirections are implicitly backquoted.
-
-(define (backq form rename)
-  (list (rename 'quasiquote) form)) 	; form -> `form
-(define (unq form rename)
-  (list (rename 'unquote) form)) 	; form -> ,form
-
-(define (make-backquoter rename)
-  (lambda (form) (list (rename 'quasiquote) form)))
-(define (make-unquoter rename)
-  (lambda (form) (list (rename 'unquote) form)))
+;;; the following utilities may be superfluous
+;;; <unknown_lamer> or rather, is there no overhead for having nested
+;;;                 begins (we're talking... potentially 10+ levels
+;;;                 deep generated by the macro)
+;;; <wingo> of course not.
hunk ./module/scsh/syntax-helpers.scm 40
-(define (deblock exp rename compare)
-  (let ((%block (rename 'begin)))
-    (let deblock1 ((exp exp))
-      (if (and (pair? exp)
-	       (name? (car exp))
-	       (compare %block (car exp)))
-	  (apply append (map deblock1 (cdr exp)))
-	  (list exp)))))
+(define (deblock exp)
+  (syntax-case exp ()
+    ((expressions ...)
+     (let deblock1 ((exp exp))
+       (syntax-case exp (begin)
+	 ((begin form0 forms ...)
+	  (with-syntax (((rest ...)
+			 (apply append (map deblock1 (syntax (forms ...))))))
+	    #`(form0 . (rest ...))))
+	 ((head tail ...)
+	  #'((head tail ...)))
+	 (form #'(form)))))))
hunk ./module/scsh/syntax-helpers.scm 56
-(define (blockify exps rename compare)
-  (let ((new-exps (apply append
-			 (map (lambda (exp) (deblock exp rename compare))
-			      exps))))
-    (cond ((null? new-exps)
-	   (error "Empty BEGIN" exps))
-	  ((null? (cdr new-exps))	; (begin exp) => exp
-	   (car new-exps))
-	  (else `(,(rename 'begin) . ,new-exps)))))
+(define (blockify exp)
+  #`(begin #,@(deblock exp)))
hunk ./module/scsh/syntax-helpers.scm 59
-(define (thunkate code rename compare)
-  (let ((%lambda (rename 'lambda)))
-    `(,%lambda () ,@(deblock code rename compare))))
+(define (thunkate code)
+  #`(lambda () #,@(deblock code)))
hunk ./module/scsh/syntax-helpers.scm 78
-(define (transcribe-process-form pf rename compare)
-  (if (and (list? pf) (pair? pf))
-      (let ((head (car pf)))
-	(cond 
-	 ((compare head (rename 'begin)) 
-	  (transcribe-begin-process-form (cdr pf) rename compare))
-
-	 ((compare head (rename 'epf))
-	  (transcribe-extended-process-form (cdr pf) rename compare))
-
-	 ((compare head (rename 'pipe))
-	  (transcribe-simple-pipeline (cdr pf) rename compare))
-
-	 ((compare head (rename '|))
-	  (transcribe-simple-pipeline (cdr pf) rename compare))
-
-	 ((compare head (rename '|+))
-	  (let ((conns (backq (cadr pf) rename))
-		(pfs (cddr pf)))
-	    (transcribe-complex-pipeline conns pfs rename compare)))
-	
-	 ((compare head (rename 'pipe+))
-	  (let ((conns (backq (cadr pf) rename))
-		(pfs (cddr pf)))
-	    (transcribe-complex-pipeline conns pfs rename compare)))
-
-	 (else	(let ((%apply (rename 'apply))
-		      (%exec-path (rename 'exec-path))
-		      (pf (backq pf rename)))
-		  `(,%apply ,%exec-path ,pf)))))
-      (error "Illegal process form" pf)))
-
-
-(define (transcribe-begin-process-form body rename compare)
-  (let ((%with-stdio-ports* (rename 'with-stdio-ports*))
-	(%lambda          (rename 'lambda)))
-    `(,%with-stdio-ports* (,%lambda () . ,body))))
-
-
-(define (transcribe-simple-pipeline pfs rename compare)
-  (if (null? pfs) (error "Empty pipeline")
-      (let* ((%fork/pipe (rename 'fork/pipe))
-	     (trans-pf (lambda (pf)
-			  (transcribe-process-form pf rename compare)))
-	     (chunks (reverse (map trans-pf pfs)))
-	     (last-chunk (car chunks))
-	     (first-chunks (reverse (cdr chunks)))
-	     (forkers (map (lambda (chunk)
-			     `(,%fork/pipe ,(thunkate chunk rename compare)))
-			   first-chunks)))
-	(blockify `(,@forkers ,last-chunk) rename compare))))
-
-
-;;; Should let-bind CONNS in case it's a computed form.
-
-(define (transcribe-complex-pipeline conns pfs rename compare)
-  (if (null? pfs) (error "Empty pipeline")
-      (let* ((%fork/pipe+ (rename 'fork/pipe+))
-	     (trans-pf (lambda (pf)
-			 (transcribe-process-form pf rename compare)))
-	     (chunks (reverse (map trans-pf pfs)))
-	     (last-chunk (car chunks))
-	     (first-chunks (reverse (cdr chunks)))
-	     (forkers (map (lambda (chunk)
-			     `(,%fork/pipe+ ,conns
-					    ,(thunkate chunk rename compare)))
-			   first-chunks)))
-	(blockify `(,@forkers ,last-chunk) rename compare))))
-      
-
-(define (transcribe-extended-process-form epf rename compare)
-  (let* ((pf (car epf))		; First form is the process form.
-	 (redirs (cdr epf)) 	; Others are redirection forms.
-	 (trans-redir (lambda (r) (transcribe-redirection r rename compare)))
-	 (redir-chunks (map trans-redir redirs))
-	 (pf-chunk (transcribe-process-form pf rename compare)))
-    (blockify `(,@redir-chunks ,pf-chunk) rename compare)))
-
-
-(define (transcribe-redirection redir rename compare)
-  (let* ((backq (make-backquoter rename))
-	 (parse-spec (lambda (x default-fdes) ; Parse an ([fdes] arg) form.
-		       ;; X  must be a list of 1 or 2 elts.
-		       (check-arg (lambda (x) (and (list? x)
-						   (< 0 (length x) 3)))
-				  x transcribe-redirection)
-		       (let ((a (car x))
-			     (b (cdr x)))
-			 (if (null? b) (values default-fdes (backq a))
-			     (values (backq a) (backq (car b)))))))
-	 (oops (lambda () (error "unknown i/o redirection" redir)))
-	 (%open (rename 'shell-open))
-;	 (%dup-port (rename 'dup-port))
-	 (%dup->fdes (rename 'dup->fdes))
-;	 (%run/port (rename 'run/port))
-	 (%open-string-source (rename 'open-string-source))
-	 (%open/create+trunc (rename 'open/create+trunc))
-	 (%open/write+append+create (rename 'open/write+append+create))
-	 (%q (lambda (x) (list (rename 'quote) x)))
-	 (%close (rename 'close))
-	 (%move->fdes (rename 'move->fdes))
-	 (%set! (rename 'set!))
-	 (%<<-port-holder (rename '<<-port-holder))
-	 (%let (rename 'let))
-	 (%port (rename 'port))
-	 (%stdports->stdio (rename 'stdports->stdio)))
-    (cond ((pair? redir)
-	   (let ((args (cdr redir))
-		 (op (car redir)))
-	     (cond 
-	      ((compare op (rename '<))
-	       (receive (fdes fname) (parse-spec args 0)
-		 `(,%open ,fname 0 ,fdes)))
-
-	      ((compare op (rename '>))
-	       (receive (fdes fname) (parse-spec args 1)
-		 `(,%open ,fname ,%open/create+trunc ,fdes)))
-
-	       ;;; BUG BUG -- EPF is backquoted by parse-spec.
-;	       ((<<<) ; Just a RUN/PORT with a specific target fdes.
-;		(receive (fdes epf) (parse-spec args 0)
-;		  `(,%dup-port (,%run/port . ,epf) ,fdes))) ; Add a WITH-PORT.
-
-	      ;; We save the port in the global variable <<-port-holder to prevent a
-	      ;; GC from closing the port before the exec().
-	      ((compare op (rename '<<))
-	       (receive (fdes exp) (parse-spec args 0)
-		 `(,%let ((,%port (,%open-string-source ,exp)))
-			 (,%set! ,%<<-port-holder ,%port)
-			 (,%move->fdes ,%port ,fdes))))
-
-	      ((compare op (rename '>>))
-	       (receive (fdes fname) (parse-spec args 1)
-		 `(,%open ,fname ,%open/write+append+create ,fdes)))
-
-	      ((compare op (rename '=))
-	       (assert (= 2 (length args))) ; Syntax check.
-	       `(,%dup->fdes ,(backq (cadr args)) ,(backq (car args))))
-
-	      ((compare op (rename '-))	; (- fdes) => close the fdes.
-	       (assert (= 1 (length args))) ; Syntax check.
-	       `(,%close ,(backq (car args))))
-
-	      (else (oops)))))
-
-	  ((compare redir (rename 'stdports))
-	   `(,%stdports->stdio))
-	  (else (oops)))))
+;;; does not use deblock/blockify/thunkate for now (see above comments
+;;; on nested begin efficiency)
+(define (expand-process-form expression)
+  (syntax-case expression (begin epf pipe | |+ pipe+)
+    ((begin forms ...)
+     #'(with-stdio-ports* (lambda () forms ...)))
+    ((epf (pf1 pf2 ...) redirection ...)
+     #`(begin #,@(map expand-redirection #'(redirection ...))
+	      #,(expand-process-form #'(pf1 pf2 ...))))
+    ((pipe pf1 pf2 ... pfn)
+     #`(begin #,@(map (lambda (chunk)
+			#`(fork/pipe (lambda () #,(expand-process-form chunk))))
+		      #'(pf1 pf2 ...))
+	      #,(expand-process-form #'pfn)))
+;;;    ((| forms ...)) ; b0rks paredit... ignore for a sec
+;;;   ((|+ forms ...))
+    ((pipe+ (connection ...) pf1 pf2 ... pfn)
+     #`(begin #,@(map (lambda (chunk)
+			#`(fork/pipe+ `(connection ...)
+				      (lambda () #,(expand-process-form chunk))))
+		      #'(pf1 pf2 ...))
+	      #,(expand-process-form #'pfn)))
+    ((command forms ...)
+     (syntax (apply exec-path `(command forms ...))))))
hunk ./module/scsh/syntax-helpers.scm 103
-;;; <<< should be {
+(define (expand-redirection redirection)
+  (syntax-case redirection (< > << >> = - stdports)
+    ;; (REDIR FILE-NAME) -> expand again
+    ((< file-name)
+     (expand-redirection #'(< 0 file-name)))
+    ((> file-name)
+     (expand-redirection #'(> 1 file-name)))
+    ((<< object)
+     (expand-redirection #'(<< 0 object)))
+    ((>> file-name)
+     (expand-redirection #'(>> 1 file-name)))
+    
+    ((< fdes file-name)
+     #'(shell-open `file-name 0 `fdes))
+    ((> fdes file-name)
+     #'(shell-open `file-name open/create+trunc `fdes))
+    ((<< fdes object)
+     #'(let ((port (open-string-source `object)))
+	 (set! <<-port-holder port)
+	 (move->fdes port `fdes)))
+    ((>> fdes file-name)
+     #'(shell-open `file-name open/write+append+create `fdes))
+    ((= fdes fdes/port)
+     #'(dup->fdes `fdes/port `fdes))
+    ((- fdes)
+     #'(close fdes))
+    (stdports
+     #'(stdports->stdio))))
hunk ./module/scsh/syntax.scm 8
-;; This is used by the macro for the << redirection to prevent the temporary 
-;; port from being closed by a GC before the process exec's
-(define <<-port-holder)
+(define-modules (scsh syntax)
+  #:use-module (scsh syntax-helpers)
+  #:export (exec-pf
+	    || && :or:
+	    run/collecting
+	    run/port+proc
+	    run/port
+	    run/strings
+	    run/file
+	    run/string
+	    run/sexp
+	    run/sexps
+	    run/pty))
hunk ./module/scsh/syntax.scm 23
-  (lambda (form rename compare)
-    (transcribe-extended-process-form (cdr form) rename compare)))
+  (lambda (form)
+    (syntax-case form ()
+      ((_ forms ...)
+       (expand-process-form #'(forms ...))))))
+