scsh-0.5/scsh/syntax-helpers.scm

;;; Macro expanding procs for scsh.
;;; Written for Clinger/Rees explicit renaming macros.
;;; Needs name-export and receive-syntax S48 packages.
;;; Also needs scsh's utilities package (optional-arg & check-arg).
;;; Must be loaded into for-syntax package.
;;; Copyright (c) 1993 by Olin Shivers.

(define-syntax define-simple-syntax
  (syntax-rules ()
    ((define-simple-syntax (name . pattern) result)
     (define-syntax name (syntax-rules () ((name . pattern) result))))))

(define (name? thing)
  (or (symbol? thing)
      (generated? thing)))

;;; Debugging macro:
(define-simple-syntax (assert exp)
  (if (not exp) (error "Assertion failed" (quote exp))))

;;; 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)))

;; DEBLOCK maps an expression to a list of expressions, flattening BEGINS.
;; (deblock '(begin (begin 3 4) 5 6 (begin 7 8))) => (3 4 5 6 7 8)

(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)))))

;; BLOCKIFY maps an expression list to a BEGIN form, flattening nested BEGINS.
;; (blockify '( (begin 3 4) 5 (begin 6) )) => (begin 3 4 5 6)

(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 (thunkate code rename compare)
  (let ((%lambda (rename 'lambda)))
    `(,%lambda () ,@(deblock code rename compare))))

;;; Process forms are rewritten into code that causes them to execute
;;; in the current process.
;;; (BEGIN . scheme-code)	=> (STDIO->STDPORTS (LAMBDA () . scheme-code))
;;; (| pf1 pf2)			=> (BEGIN (FORK/PIPE (LAMBDA () pf1-code))
;;;                                       pf2-code)
;;; (|+ conns pf1 pf2)		=> (BEGIN
;;;                                  (FORK/PIPE+ `conns (LAMBDA () pf1-code))
;;;                                  pf2-code)
;;; (epf . epf)			=> epf-code
;;; (prog arg1 ... argn)	=> (APPLY EXEC-PATH `(prog arg1 ... argn))
;;; [note the implicit backquoting of PROG, ARG1, ...]

;;; NOTE: | and |+ won't read into many Scheme's as a symbol. If your
;;; Scheme doesn't handle it, kill them, and just use the PIPE, PIPE+
;;; aliases.

(define (transcribe-process-form pf rename compare)
  (if (and (list? pf) (pair? pf))
      (case (car pf)
	((begin) (transcribe-begin-process-form (cdr pf) rename compare))

	((epf)	(transcribe-extended-process-form (cdr pf) rename compare))

	((pipe)	(transcribe-simple-pipeline (cdr pf) rename compare))
	((|)	(transcribe-simple-pipeline (cdr pf) rename compare))

	((|+)	(let ((conns (backq (cadr pf) rename))
		      (pfs (cddr pf)))
		  (transcribe-complex-pipeline conns pfs rename compare)))
	((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)))



;;; These two utility funs are for parsing optional last arguments,
;;; e.g. the PORT arg in
;;;    (write-string string [port])
;;;    (define (write-string str . maybe-port) ...).

(define (optional-arg maybe-arg default)
  (cond ((null? maybe-arg) default)
	((null? (cdr maybe-arg))  (car maybe-arg))
	(else (error "too many optional arguments" maybe-arg))))


(define (optional-arg* maybe-arg default-thunk)
  (if (null? maybe-arg) (default-thunk) (car maybe-arg)))


(define (check-arg pred val caller)
  (let lp ((val val))
    (if (pred val) val
	(lp (error "Bad argument" val))))) ; Loop doesn't really work.


(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))
	 (%stdports->stdio (rename 'stdports->stdio)))
    (cond ((pair? redir)
	   (let ((args (cdr redir)))
	     (case (car redir)
	       ((<)
		(receive (fdes fname) (parse-spec args 0)
		  `(,%open ,fname 0 ,fdes)))

	       ((>)
		(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.

	       ((<<)
		(receive (fdes exp) (parse-spec args 0)
		  `(,%move->fdes (,%open-string-source ,exp) ,fdes)))

	       ((>>)
		(receive (fdes fname) (parse-spec args 1)
		  `(,%open ,fname ,%open/write+append+create ,fdes)))

	       ((=)
		(assert (= 2 (length args))) ; Syntax check.
		`(,%dup->fdes ,(backq (cadr args)) ,(backq (car args))))

	       ((-)	; (- fdes) => close the fdes.
		(assert (= 1 (length args))) ; Syntax check.
		`(,%close ,(backq (car args))))

	       (else (oops)))))

	  ((eq? redir 'stdports)
	   `(,%stdports->stdio))
	  (else (oops)))))

;;; <<< should be {