[[project @ 1997-07-26 20:52:13 by ghouston]
ghouston**19970726205219
 Ignore-this: 6e02e6d4c67c515df657de7aeff663f9
 * init.scm: load syntax-helpers.scm.
 
 * Makefile.am (scsh_DATA): add syntax-helpers.scm.
 * syntax-helpers.scm: new file from scsh 0.5.1.
 (name?): make it the same as symbol?
 
 * scsh.scm: define call-terminally.
 define with-env*, with-total-env*, with-cwd*, with-umask* and
 the macro versions.
 
 * syscalls.scm: redefine exit, pipe (ugh).
 Define cwd, set-umask.
 Include environment stuff, gives only alist->env and env->alist.
] addfile ./syntax-helpers.scm
hunk ./ChangeLog 1
+Sat Jul 26 06:22:36 1997  Gary Houston  <ghouston@actrix.gen.nz>
+
+	* init.scm: load syntax-helpers.scm.
+
+	* Makefile.am (scsh_DATA): add syntax-helpers.scm.
+	* syntax-helpers.scm: new file from scsh 0.5.1.
+	(name?): make it the same as symbol?
+
+	* scsh.scm: define call-terminally.
+	define with-env*, with-total-env*, with-cwd*, with-umask* and
+	the macro versions.
+
+	* syscalls.scm: redefine exit, pipe (ugh).
+	Define cwd, set-umask.
+	Include environment stuff, gives only alist->env and env->alist.
+
hunk ./Makefile.am 10
-	rw.scm scsh.scm syntax.scm syscalls.scm time.scm utilities.scm
+	rw.scm scsh.scm syntax.scm syntax-helpers.scm syscalls.scm \
+	time.scm utilities.scm
hunk ./init.scm 36
+(load-from-path "scsh/syntax-helpers.scm")
+
hunk ./scsh.scm 7
+;;; Call THUNK, then die.
+;;; A clever definition in a clever implementation allows the caller's stack
+;;; and dynamic env to be gc'd away, since this procedure never returns.
+
+;;; (define (call-terminally thunk)
+;;;  (with-continuation #f (lambda () (thunk) (exit 0))))
+;;;  ;; Alternatively: (with-continuation #f thunk)
+
+;;; More portably, but less usefully:
+(define (call-terminally thunk)
+  (thunk)
+  (exit 0))
+
hunk ./scsh.scm 114
+(define (with-env* alist-delta thunk)
+  (let* ((old-env #f)
+	 (new-env (reduce (lambda (alist key/val)
+			    (alist-update (car key/val) (cdr key/val) alist))
+			  (env->alist)
+			  alist-delta)))
+    (dynamic-wind
+      (lambda ()
+	(set! old-env (env->alist))
+	(alist->env new-env))
+      thunk
+      (lambda ()
+	(set! new-env (env->alist))
+	(alist->env old-env)))))
+
+(define (with-total-env* alist thunk)
+  (let ((old-env (env->alist)))
+    (dynamic-wind
+      (lambda ()
+	(set! old-env (env->alist))
+	(alist->env alist))
+      thunk
+      (lambda ()
+	(set! alist (env->alist))
+	(alist->env old-env)))))
+
+
+(define (with-cwd* dir thunk)
+  (let ((old-wd #f))
+    (dynamic-wind
+      (lambda ()
+	(set! old-wd (cwd))
+	(chdir dir))
+      thunk
+      (lambda ()
+	(set! dir (cwd))
+	(chdir old-wd)))))
+
+(define (with-umask* mask thunk)
+  (let ((old-mask #f))
+    (dynamic-wind
+      (lambda ()
+	(set! old-mask (umask))
+	(set-umask mask))
+      thunk
+      (lambda ()
+	(set! mask (umask))
+	(set-umask old-mask)))))
+
+;;; Sugar:
+
+(define-simple-syntax (with-cwd dir . body)
+  (with-cwd* dir (lambda () . body)))
+
+(define-simple-syntax (with-umask mask . body)
+  (with-umask* mask (lambda () . body)))
+
+(define-simple-syntax (with-env delta . body)
+  (with-env* `delta (lambda () . body)))
+
+(define-simple-syntax (with-total-env env . body)
+  (with-total-env* `env (lambda () . body)))
+
+
hunk ./syntax-helpers.scm 1
+;;; 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 (for CHECK-ARG).
+;;; Must be loaded into for-syntax package.
+;;; Copyright (c) 1993 by Olin Shivers.
+
+;; modified for Guile.  process forms not ported yet.
+
+(define-syntax define-simple-syntax
+  (syntax-rules ()
+    ((define-simple-syntax (name . pattern) result)
+     (define-syntax name (syntax-rules () ((name . pattern) result))))))
+
+(define (name? thing)
+  (symbol? 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)))
+
+
+(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 {
hunk ./syscalls.scm 4
-;; Only the subset from scsh that's useful in Guile, rewritten in places. 
-;; Incomplete.
+;; Rewritten for Guile in places, incomplete.
+
+(set! exit primitive-exit)
+
+;;; Miscellaneous process state
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Working directory
+
+(define-foreign %chdir/errno
+  (chdir (string directory))
+  (to-scheme integer errno_or_false))
+
+(define-errno-syscall (%chdir dir) %chdir/errno)
+
+;; primitive in Guile.
+;;(define (chdir . maybe-dir)
+;;  (let ((dir (:optional maybe-dir (home-dir))))
+;;    (%chdir (ensure-file-name-is-nondirectory dir))))
+
+
+(define-foreign cwd/errno (scheme_cwd)
+  (to-scheme integer "False_on_zero") ; errno or #f
+  string) ; directory (or #f on error)
+
+(define-errno-syscall (cwd) cwd/errno
+  dir)
+
+(define cwd getcwd)
+
+(if (not (defined? 'guile-pipe))
+    (define guile-pipe pipe))
+(set! pipe (lambda ()
+	     (let ((rv (guile-pipe)))
+	       (values (car rv) (cdr rv)))))
+
+;;; UMASK
+
+(define-foreign set-umask (umask (mode_t mask)) no-declare ; integer on SunOS
+  mode_t)
+
+;; primitive in Guile.
+;;(define (umask)
+;;  (let ((m (set-umask 0)))
+;;    (set-umask m)
+;;    m))
+
+(define (set-umask newmask) (umask newmask))
hunk ./syscalls.scm 132
+
+;;; Environment manipulation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; (var . val) / "var=val" rep conversion:
+
+(define (split-env-string var=val)
+  (let ((i (index var=val #\=)))
+    (if i (values (substring var=val 0 i)
+		  (substring var=val (+ i 1) (string-length var=val)))
+	(error "No \"=\" in environment string" var=val))))
+
+(define (env-list->alist env-list)
+  (map (lambda (var=val)
+	 (call-with-values (lambda () (split-env-string var=val))
+			   cons))
+       env-list))
+
+(define (alist->env-list alist)
+  (map (lambda (var.val)
+	 (string-append (car var.val) "=" (cdr var.val)))
+       alist))
+
+;;; ENV->ALIST
+
+(define-foreign %load-env (scm_envvec)
+  (C char**)	; char **environ
+  fixnum)	; & its length.
+
+;(define (env->list)
+;  (receive (C-env nelts) (%load-env)
+;    (vector->list (C-string-vec->Scheme C-env nelts))))
+
+(define (env->alist) (env-list->alist (environ)))
+
+;;; ALIST->ENV
+
+(define-foreign %install-env/errno
+  (install_env (vector-desc env-vec))
+  (to-scheme integer errno_or_false))
+
+(define-errno-syscall (%install-env env-vec) %install-env/errno)
+
+(define (alist->env alist)
+  (environ (alist->env-list alist)))
+
+;;; GETENV, PUTENV, SETENV
+
+(define-foreign getenv (getenv (string var))
+  static-string)
+
+(foreign-source
+ "#define errno_on_nonzero_or_false(x) ((x) ? ENTER_FIXNUM(errno) : SCHFALSE)"
+ "" "")
+
+;(define-foreign putenv/errno
+;  (put_env (string var=val))
+;  desc) ; #f or errno
+
+
+;;; putenv takes a constant: const char *, cig can't figure that out..
+(define-foreign putenv/errno
+  (putenv (string-copy var=val))  no-declare
+  (to-scheme integer errno_on_nonzero_or_false)) ; #f or errno
+
+(define-foreign delete-env (delete_env (string var))
+  ignore)
+
+;; primitive in Guile.
+;; (define (putenv var=val)
+;;  (if (putenv/errno var=val)
+;;      (error "malloc failure in putenv" var=val)))
+;;
+;; in Guile's boot-9.scm.
+;; (define (setenv var val)
+;;  (if val
+;;      (putenv (string-append var "=" val))
+;;      (delete-env var)))