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) (define (transcribe-process-form pf rename compare)
(if (and (list? pf) (pair? pf)) (if (and (list? pf) (pair? pf))
(case (car pf) (let ((head (car pf)))
((begin) (transcribe-begin-process-form (cdr pf) rename compare)) (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)) ((compare head (rename 'pipe))
((|) (transcribe-simple-pipeline (cdr pf) rename compare)) (transcribe-simple-pipeline (cdr pf) rename compare))
((|+) (let ((conns (backq (cadr pf) rename)) ((compare head (rename '|))
(pfs (cddr pf))) (transcribe-simple-pipeline (cdr pf) rename compare))
(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)) ((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)) (%exec-path (rename 'exec-path))
(pf (backq pf rename))) (pf (backq pf rename)))
`(,%apply ,%exec-path ,pf)))) `(,%apply ,%exec-path ,pf)))))
(error "Illegal process form" pf))) (error "Illegal process form" pf)))
@ -173,44 +182,45 @@
(%port (rename 'port)) (%port (rename 'port))
(%stdports->stdio (rename 'stdports->stdio))) (%stdports->stdio (rename 'stdports->stdio)))
(cond ((pair? redir) (cond ((pair? redir)
(let ((args (cdr redir))) (let ((args (cdr redir))
(case (car redir) (op (car redir)))
((<) (cond
(receive (fdes fname) (parse-spec args 0) ((compare op (rename '<))
`(,%open ,fname 0 ,fdes))) (receive (fdes fname) (parse-spec args 0)
`(,%open ,fname 0 ,fdes)))
((>) ((compare op (rename '>))
(receive (fdes fname) (parse-spec args 1) (receive (fdes fname) (parse-spec args 1)
`(,%open ,fname ,%open/create+trunc ,fdes))) `(,%open ,fname ,%open/create+trunc ,fdes)))
;;; BUG BUG -- EPF is backquoted by parse-spec. ;;; BUG BUG -- EPF is backquoted by parse-spec.
; ((<<<) ; Just a RUN/PORT with a specific target fdes. ; ((<<<) ; Just a RUN/PORT with a specific target fdes.
; (receive (fdes epf) (parse-spec args 0) ; (receive (fdes epf) (parse-spec args 0)
; `(,%dup-port (,%run/port . ,epf) ,fdes))) ; Add a WITH-PORT. ; `(,%dup-port (,%run/port . ,epf) ,fdes))) ; Add a WITH-PORT.
;; We save the port in the global variable <<-port-holder to prevent a ;; We save the port in the global variable <<-port-holder to prevent a
;; GC from closing the port before the exec(). ;; GC from closing the port before the exec().
((<<) ((compare op (rename '<<))
(receive (fdes exp) (parse-spec args 0) (receive (fdes exp) (parse-spec args 0)
`(,%let ((,%port (,%open-string-source ,exp))) `(,%let ((,%port (,%open-string-source ,exp)))
(,%set! ,%<<-port-holder ,%port) (,%set! ,%<<-port-holder ,%port)
(,%move->fdes ,%port ,fdes)))) (,%move->fdes ,%port ,fdes))))
((>>) ((compare op (rename '>>))
(receive (fdes fname) (parse-spec args 1) (receive (fdes fname) (parse-spec args 1)
`(,%open ,fname ,%open/write+append+create ,fdes))) `(,%open ,fname ,%open/write+append+create ,fdes)))
((=) ((compare op (rename '=))
(assert (= 2 (length args))) ; Syntax check. (assert (= 2 (length args))) ; Syntax check.
`(,%dup->fdes ,(backq (cadr args)) ,(backq (car args)))) `(,%dup->fdes ,(backq (cadr args)) ,(backq (car args))))
((-) ; (- fdes) => close the fdes. ((compare op (rename '-)) ; (- fdes) => close the fdes.
(assert (= 1 (length args))) ; Syntax check. (assert (= 1 (length args))) ; Syntax check.
`(,%close ,(backq (car args)))) `(,%close ,(backq (car args))))
(else (oops))))) (else (oops)))))
((eq? redir 'stdports) ((compare redir (rename 'stdports))
`(,%stdports->stdio)) `(,%stdports->stdio))
(else (oops))))) (else (oops)))))