scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Use "compare" und "rename" to compare symbols.

This commit is contained in:
mainzelm 2002-10-21 17:30:49 +00:00
parent d1142b703c
commit 96060828fa
1 changed files with 49 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
scsh/syntax-helpers.scm
View File

@ -77,25 +77,34 @@
(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))
(let ((head (car pf)))
(cond
((compare head (rename 'begin))
(transcribe-begin-process-form (cdr pf) rename compare))
((epf) (transcribe-extended-process-form (cdr pf) rename compare))
((compare head (rename 'epf))
(transcribe-extended-process-form (cdr pf) rename compare))
((pipe) (transcribe-simple-pipeline (cdr pf) rename compare))
((|) (transcribe-simple-pipeline (cdr pf) rename compare))
((compare head (rename 'pipe))
(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)))
((compare head (rename '|))
(transcribe-simple-pipeline (cdr pf) rename compare))
(else (let ((%apply (rename 'apply))
((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))))
`(,%apply ,%exec-path ,pf)))))
(error "Illegal process form" pf)))
@ -173,44 +182,45 @@
(%port (rename 'port))
(%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)))
(let ((args (cdr redir))
(op (car redir)))
(cond
((compare op (rename '<))
(receive (fdes fname) (parse-spec args 0)
`(,%open ,fname 0 ,fdes)))
((>)
(receive (fdes fname) (parse-spec args 1)
`(,%open ,fname ,%open/create+trunc ,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().
((<<)
(receive (fdes exp) (parse-spec args 0)
`(,%let ((,%port (,%open-string-source ,exp)))
(,%set! ,%<<-port-holder ,%port)
(,%move->fdes ,%port ,fdes))))
;; 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))))
((>>)
(receive (fdes fname) (parse-spec args 1)
`(,%open ,fname ,%open/write+append+create ,fdes)))
((compare op (rename '>>))
(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))))
((compare op (rename '=))
(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))))
((compare op (rename '-)) ; (- fdes) => close the fdes.
(assert (= 1 (length args))) ; Syntax check.
`(,%close ,(backq (car args))))
(else (oops)))))
(else (oops)))))
((eq? redir 'stdports)
((compare redir (rename 'stdports))
`(,%stdports->stdio))
(else (oops)))))