Split scsh code into lots of modules.

Note that this change doesn't represent any sort of design suggestion
or decision:  It merely represents an attempt to codify the
dependencies between the parts of the code base.  There's still lots
of work to be done to actually make user-accessible modules.

Makefile.in

@@ -771,22 +771,32 @@ $(CIG).image: $(IMAGE) $(VM) $(srcdir)/cig/cig.scm $(srcdir)/cig/libcig.scm
 scsh: scsh/scsh scsh/scsh.image
 
 SCHEME =scsh/awk.scm \
+	scsh/command-line.scm \
+	scsh/continuation.scm \
+	scsh/crypt.scm \
 	scsh/defrec.scm \
+	scsh/directory.scm \
+	scsh/dot-locking.scm \
 	scsh/endian.scm \
 	scsh/enumconst.scm \
+	scsh/environment.scm \
 	scsh/event.scm \
-	scsh/low-interrupt.scm \
+	scsh/fcntl.scm \
+	scsh/fd-syscalls.scm \
 	scsh/fdports.scm \
+	scsh/file.scm \
 	scsh/fileinfo.scm \
 	scsh/filemtch.scm \
 	scsh/filesys.scm \
 	scsh/flock.scm \
 	scsh/fname.scm \
+	scsh/fname-system.scm \
 	scsh/fr.scm \
 	scsh/glob.scm \
-	scsh/dot-locking.scm \
 	scsh/here.scm \
+	scsh/import-os-error-syscall.scm \
 	scsh/libscsh.scm \
+	scsh/low-interrupt.scm \
 	scsh/machine/bufpol.scm \
 	scsh/machine/errno.scm \
 	scsh/machine/fdflags.scm \
@@ -800,25 +810,33 @@ SCHEME =scsh/awk.scm \
 	scsh/meta-arg.scm \
 	scsh/network.scm \
 	scsh/newports.scm \
+	scsh/port-collect.scm \
+	scsh/process-high-level.scm \
+	scsh/process-state.scm \
+	scsh/process.scm \
 	scsh/procobj.scm \
 	scsh/pty.scm \
 	scsh/rdelim.scm \
+	scsh/resource.scm \
 	scsh/rw.scm \
 	scsh/scsh-condition.scm \
 	scsh/scsh-interfaces.scm \
 	scsh/scsh-package.scm \
 	scsh/scsh-read.scm \
 	scsh/scsh-version.scm \
-	scsh/scsh.scm \
 	scsh/sighandlers.scm \
+	scsh/signal.scm \
 	scsh/startup.scm \
+	scsh/stdio.scm \
 	scsh/stringcoll.scm \
 	scsh/syntax-helpers.scm \
 	scsh/syntax.scm \
-	scsh/syscalls.scm \
+	scsh/system.scm \
+	scsh/temp-file.scm \
 	scsh/time.scm \
 	scsh/top.scm \
 	scsh/tty.scm \
+	scsh/user-group.scm \
 	scsh/utilities.scm \
 	scsh/weaktables.scm \
 	scsh/rx/packages.scm \

scsh/command-line.scm

@@ -0,0 +1,31 @@
+;;; Command-line argument access
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Some globals.
+(define %command-line '())		; Includes program.
+(define command-line-arguments #f)	; Doesn't include program.
+
+(define (set-command-line-args! args)
+  (set! %command-line args)
+  (set! command-line-arguments (append (cdr args) '())))
+
+(define (arg* arglist n . maybe-default-thunk)
+  (let ((oops (lambda () (error "argument out of bounds" arglist n))))
+    (if (< n 1) (oops)
+	(let lp ((al arglist) (n n))
+	  (if (pair? al)
+	      (if (= n 1) (car al)
+		  (lp (cdr al) (- n 1)))
+	      (if (and (pair? maybe-default-thunk)
+		       (null? (cdr maybe-default-thunk)))
+		  ((car maybe-default-thunk))
+		  (oops)))))))
+
+(define (arg arglist n . maybe-default)
+  (if maybe-default (arg* arglist n (lambda () (car maybe-default)))
+      (arg* arglist n)))
+
+(define (argv n . maybe-default)
+  (apply arg %command-line (+ n 1) maybe-default))
+
+(define (command-line) (append %command-line '()))

scsh/continuation.scm

@@ -0,0 +1,21 @@
+;;; Move this to somewhere else as soon as Marc has published his SRFI
+(define (continuation-capture receiver)
+  ((call-with-current-continuation
+    (lambda (cont)
+      (lambda () (receiver cont))))))
+
+(define (continuation-graft cont thunk)
+  (cont thunk))
+
+(define (continuation-return cont . returned-values)
+  (continuation-graft
+   cont
+   (lambda () (apply values returned-values))))
+
+;;; Call THUNK, then die.
+
+(define (call-terminally thunk)
+  (with-continuation null-continuation thunk))
+
+;; from shift-reset.scm:
+(define null-continuation #f)

scsh/crypt.scm

@@ -0,0 +1,10 @@
+(import-os-error-syscall %crypt (key salt) "scm_crypt")
+
+(define (crypt key salt)
+  (let* ((allowed-char-set  (rx (| alpha digit "." "/")))
+	 (salt-regexp  (rx (: ,allowed-char-set ,allowed-char-set))))
+    (if (not (= (string-length salt) 2)) (error "salt must have length 2"))
+    (if (not (regexp-search? salt-regexp salt))
+	(error "illegal char in salt " salt))
+    (if (> (string-length key) 8) (error "key too long "  (string-length key)))
+    (%crypt key salt)))

scsh/directory.scm

@@ -0,0 +1,66 @@
+;;; Directory stuff
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (directory-files . args)
+  (with-resources-aligned
+   (list cwd-resource euid-resource egid-resource)
+   (lambda ()
+     (let-optionals args ((dir       ".")
+			  (dotfiles? #f))
+       (check-arg string? dir directory-files)
+       (let* ((files (%open-dir (ensure-file-name-is-nondirectory dir)))
+	      (files-sorted ((structure-ref sort sort-list!) files filename<=)))
+	 (if dotfiles?
+	     files-sorted
+	     (filter (lambda (f) (not (dotfile? f)))
+		     files-sorted)))))))
+
+(define (dotfile? f)
+  (char=? (string-ref f 0) #\.))
+
+(define (filename<= f1 f2)
+  (if (dotfile? f1)
+      (if (dotfile? f2)
+	  (string<= f1 f2)
+	  #t)
+      (if (dotfile? f2)
+	  #f
+	  (string<= f1 f2))))
+
+; A record for directory streams.  It just has the name and a byte vector
+; containing the C directory object.  The name is used only for printing.
+
+(define-record directory-stream
+  name
+  c-dir)
+
+(define-record-discloser type/directory-stream
+  (lambda (ds)
+    (list 'directory-stream (directory-stream:name ds))))
+
+; Directory streams are meaningless in a resumed image.
+(define-record-resumer type/directory-stream #f)
+
+(define (open-directory-stream name)
+  (let ((dir (make-directory-stream 
+	      name
+	      (with-resources-aligned 
+	       (list cwd-resource euid-resource egid-resource)
+	       (lambda ()
+		 (open-dir name))))))
+    (add-finalizer! dir close-directory-stream)
+    dir))
+
+(define (read-directory-stream dir-stream)
+  (read-dir (directory-stream:c-dir dir-stream)))
+
+(define (close-directory-stream dir-stream)
+  (let ((c-dir (directory-stream:c-dir dir-stream)))
+    (if c-dir
+	(begin
+	  (close-dir c-dir)
+	  (set-directory-stream:c-dir dir-stream #f)))))
+
+(import-os-error-syscall open-dir (name) "scm_opendir")
+(import-os-error-syscall close-dir (dir-stream) "scm_closedir")
+(import-os-error-syscall read-dir (dir-stream) "scm_readdir")

scsh/environment.scm

@@ -0,0 +1,228 @@
+;;; Environment manipulation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; (var . val) / "var=val" rep conversion:
+
+ 
+
+(define (split-env-string var=val)
+  (let ((i (string-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-vec alist)
+  (list->vector (map (lambda (var.val)
+		       (string-append (car var.val) "="
+				      (let ((val (cdr var.val)))
+					(if (string? val) val
+					    (string-join val ":")))))
+		     alist)))
+
+;;; ENV->ALIST
+
+(import-os-error-syscall %load-env () "scm_envvec")
+
+(define (environ-env->alist) 
+  (let ((env-list.envvec (%load-env)))
+    (cons (env-list->alist (car env-list.envvec)) 
+	  (cdr env-list.envvec))))
+
+	   
+;;; ALIST->ENV
+
+;;; (%create-env ((vector 'X) -> address))
+(import-os-error-syscall %create-env (envvec) "create_env")
+
+;;; assumes aligned env
+(define (envvec-alist->env alist)
+  (%create-env (alist->env-vec alist)))
+
+(import-os-error-syscall %align-env (envvec) "align_env")
+
+(import-os-error-syscall %free-env (envvec) "free_envvec")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Environment per thread
+(define *env-cache* 'uninitialized)
+(define env-lock (make-lock))
+
+(define (install-env)
+  (set! *env-cache* (environ**-read))
+  (set! $env ;;; TODO The old thread-fluid will remain
+	(make-preserved-thread-fluid
+	 (env-cache))))
+;  (set! env-lock (make-lock)))
+
+(define (env-cache)
+  *env-cache*)
+
+;; Actually do the syscall and update the cache
+;; assumes the env lock obtained
+(define (change-and-cache-env env)
+  (environ**-set env)
+  (set! *env-cache* env))
+
+;; The thread-specific env: A thread fluid
+
+(define $env 'empty-env-value)
+
+(define (thread-read-env) (thread-fluid $env))
+(define (thread-set-env! res) (set-thread-fluid! $env res))
+(define (let-env res thunk)
+  (let-thread-fluid $env res thunk))
+
+(define (really-with-env* env thunk)
+  (with-lock env-lock
+    (lambda ()
+      (change-and-cache-env env)))
+  (let-env env thunk))
+
+(define (align-env!)
+  (let ((res (thread-read-env)))
+    (if (not (env=? res (env-cache)))
+	(change-and-cache-env res))))
+
+(define (thread-change-env res)
+  (with-lock env-lock
+    (lambda ()
+      (change-and-cache-env res)
+      (thread-set-env! (env-cache)))))
+
+(define environ-resource (make-resource align-env! env-lock))
+
+(define env-reinitializer
+  (make-reinitializer install-env))
+
+(define-record env
+      envvec
+      alist)	; Corresponding alist
+
+(define-record-resumer type/env
+  (lambda (env)
+    (set-env:envvec env #f)))
+
+(define (env=? e1 e2)
+  (and (env:envvec e1)
+       (eq? (env:envvec e1) 
+	    (env:envvec e2))))
+
+(define-record envvec 
+  environ ;; char**
+  )
+
+(define (add-envvec-finalizer! envvec)
+  (add-finalizer! envvec envvec-finalizer))
+
+(define-exported-binding "envvec-record-type" type/envvec)
+(define-exported-binding "add-envvec-finalizer!" add-envvec-finalizer!)
+
+(define (envvec-finalizer envvec)
+  (%free-env envvec))
+
+(define (environ**-read)
+  (let ((alist.envvec (environ-env->alist)))
+    (make-env (cdr alist.envvec) (car alist.envvec))))
+
+(define (environ**-set env)
+   (if (env:envvec env)
+       (%align-env (env:envvec env))
+       (set-env:envvec env (envvec-alist->env (env:alist env)))))
+
+(define (getenv var)
+  (let* ((env (thread-read-env))
+	 (res (assoc var (env:alist env))))
+    (if res (cdr res) res)))
+
+(define (env->alist)
+  (env:alist (thread-read-env)))
+
+(define (setenv var val)
+  (let* ((env (thread-read-env))
+	 (alist (if val
+		    (alist-update 
+		     var 
+		     val 
+		    (env:alist env))
+		    (alist-delete
+		     var
+		     (env:alist env)))))
+    (thread-set-env! 
+     (make-env 
+      #f
+      alist))))
+
+(define (alist->env alist)
+  (thread-set-env!
+   (make-env
+    #f
+    alist)))
+
+(define (with-env* alist-delta thunk)
+  (let ((new-env (fold (lambda (key/val alist)
+			  (alist-update (car key/val) (cdr key/val) alist))
+			(env->alist)
+			alist-delta)))
+    (with-total-env* new-env thunk)))
+
+(define (with-total-env* alist thunk)
+  (really-with-env* (make-env #f alist) thunk))
+
+(define (alist-delete key alist)
+  (filter (lambda (key/val) (not (equal? key (car key/val)))) alist))
+
+(define (alist-update key val alist)
+  (cons (cons key val)
+	(alist-delete key alist)))
+
+;;; Remove shadowed entries from ALIST. Preserves element order.
+;;; (This version shares no structure.)
+
+(define (alist-compress alist) 
+  (reverse (let compress ((alist alist) (ans '()))
+	     (if (pair? alist)
+		 (let ((key/val (car alist))
+		       (alist (cdr alist)))
+		   (compress alist (if (assoc (car key/val) ans) ans
+				       (cons key/val ans))))
+		 ans))))
+
+(define (add-before elt before list)
+  (let rec ((list list))
+    (if (pair? list)
+	(let ((x (car list)))
+	  (if (equal? x before)
+	      (cons elt list)
+	      (cons x (rec (cdr list)))))
+	(cons elt list))))
+
+;;; In ADD-AFTER, the labelled LET adds ELT after the last occurrence of AFTER
+;;; in LIST, and returns the list. However, if the LET finds no occurrence 
+;;; of AFTER in LIST, it returns #F instead.
+
+(define (add-after elt after list)
+  (or (let rec ((list list))
+	(if (pair? list)
+	    (let* ((x (car list))
+		   (tail (cdr list))
+		   (ans (rec tail))) ; #f if AFTER wasn't encountered.
+	      (cond (ans (cons x ans))
+		    ((equal? x after)
+		     (cons x (cons elt tail)))
+		    (else #f)))		; AFTER doesn't appear in LIST.
+	    #f))			; AFTER doesn't appear in LIST.
+      (cons elt list)))
+
+(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)))
+
+(install-env)

scsh/fcntl.scm

@@ -0,0 +1,25 @@
+;;; fcntl()'s F_GETFD and F_SETFD.  Note that the SLEAZY- prefix on the
+;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour
+;;; of these procedures. Straight CALL/FDES modifies unrevealed file
+;;; descriptors by clearing their CLOEXEC bit when it reveals them -- so it
+;;; would interfere with the reading and writing of that bit!
+
+(define (fdes-flags fd/port)
+  (sleazy-call/fdes fd/port
+    (lambda (fd) (%fcntl-read fd fcntl/get-fdes-flags))))
+
+(define (set-fdes-flags fd/port flags)
+  (sleazy-call/fdes fd/port
+    (lambda (fd) (%fcntl-write fd fcntl/set-fdes-flags flags))))
+
+;;; fcntl()'s F_GETFL and F_SETFL.
+;;; Get: Returns open flags + get-status flags (below)
+;;; Set: append, sync, async, nbio, nonblocking, no-delay
+
+(define (fdes-status fd/port)
+  (sleazy-call/fdes fd/port
+    (lambda (fd) (%fcntl-read fd fcntl/get-status-flags))))
+
+(define (set-fdes-status fd/port flags)
+  (sleazy-call/fdes fd/port
+    (lambda (fd) (%fcntl-write fd fcntl/set-status-flags flags))))

scsh/fd-syscalls.scm

@@ -0,0 +1,23 @@
+;;; Fd-ports
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(import-os-error-syscall %set-cloexec (fd val) "set_cloexec")
+
+;;; Some of fcntl()
+;;;;;;;;;;;;;;;;;;;
+
+(import-os-error-syscall %fcntl-read (fd command) "fcntl_read")
+(import-os-error-syscall %fcntl-write (fd command val) "fcntl_write")
+
+(import-os-error-syscall %close-fdes (fd) "scsh_close")
+
+(import-os-error-syscall %dup (fd) "scsh_dup")
+
+(import-os-error-syscall %dup2 (fd-from fd-to) "scsh_dup2")
+
+(import-os-error-syscall %fd-seek (fd offset whence) "scsh_lseek")
+
+(import-os-error-syscall %char-ready-fdes? (fd) "char_ready_fdes")
+
+(import-os-error-syscall %open (path flags mode) "scsh_open")
+

scsh/file-syscalls.scm

@@ -0,0 +1,64 @@
+(import-os-error-syscall %set-cloexec (fd val) "set_cloexec")
+
+(import-os-error-syscall %fcntl-read (fd command) "fcntl_read")
+(import-os-error-syscall %fcntl-write (fd command val) "fcntl_write")
+
+(import-os-error-syscall %close-fdes (fd) "scsh_close")
+
+(import-os-error-syscall %dup (fd) "scsh_dup")
+
+(import-os-error-syscall %dup2 (fd-from fd-to) "scsh_dup2")
+
+(import-os-error-syscall %fd-seek (fd offset whence) "scsh_lseek")
+
+(import-os-error-syscall %char-ready-fdes? (fd) "char_ready_fdes")
+
+(import-os-error-syscall %open (path flags mode) "scsh_open")
+
+(import-os-error-syscall %pipe-fdes () "scheme_pipe")
+
+(import-os-error-syscall %truncate-file (path length) "scsh_truncate")
+
+(import-os-error-syscall %truncate-fdes (path length) "scsh_ftruncate")
+
+(import-os-error-syscall %create-symlink (old-name new-name) "scsh_symlink")
+  
+(import-os-error-syscall %read-symlink (path) "scsh_readlink")
+
+(import-os-error-syscall %rename-file (old-name new-name) "scsh_rename")
+
+(import-os-error-syscall %delete-directory (path) "scsh_rmdir")
+
+(import-os-error-syscall %%create-directory (path mode) "scsh_mkdir")
+
+(import-os-error-syscall %create-hard-link (original-name new-name) 
+  "scsh_link")
+
+(import-os-error-syscall %create-fifo (path mode) "scsh_mkfifo")
+
+(import-os-error-syscall %set-file-mode (path mode) "scsh_chmod")
+
+(import-os-error-syscall %set-fdes-mode (path mode) "scsh_fchmod")
+
+(import-os-error-syscall %set-file-uid&gid (path uid gid) "scsh_chown")
+
+(import-os-error-syscall %set-fdes-uid&gid (fd uid gid) "scsh_fchown")
+
+(import-os-error-syscall %utime (path ac m) "scm_utime") 
+
+(import-os-error-syscall %utime-now (path) "scm_utime_now")
+
+(import-os-error-syscall %stat-file (path data chase?) "scheme_stat")
+
+(import-os-error-syscall %stat-fdes (fd data) "scheme_fstat")
+
+(import-os-error-syscall %delete-file (path) "scsh_unlink")
+
+(import-os-error-syscall %sync-file (fd) "scsh_fsync")
+
+;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
+(import-os-error-syscall %sync-file-system () "scsh_sync")
+
+(import-os-error-syscall %open-dir (dir-name) "directory_files")
+
+

scsh/file.scm

@@ -0,0 +1,73 @@
+;;; File system
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Useful little utility for generic ops that work on filenames, fd's or
+;;; ports.
+
+(define (generic-file-op thing fd-op fname-op)
+  (if (string? thing) 
+      (with-resources-aligned (list cwd-resource euid-resource egid-resource) 
+			      (lambda () (fname-op thing)))
+      (call/fdes thing fd-op)))
+
+(define (set-file-mode thing mode)
+  (generic-file-op thing
+		   (lambda (fd)    (%set-fdes-mode fd    mode))
+		   (lambda (fname) (%set-file-mode fname mode))))
+
+(define (set-file-owner thing uid)
+  (generic-file-op thing
+		   (lambda (fd)    (%set-fdes-uid&gid fd    uid -1))
+		   (lambda (fname) (%set-file-uid&gid fname uid -1))))
+
+(define (set-file-group thing gid)
+  (generic-file-op thing
+		   (lambda (fd)    (%set-fdes-uid&gid fd    -1 gid))
+		   (lambda (fname) (%set-file-uid&gid fname -1 gid))))
+
+
+;(define (file-access? path perms)
+;  (not (%file-access-not? path perms)))
+;
+;(define (file-executable? fname)
+;  (file-access? fname 1))
+;
+;(define (file-writable? fname)
+;  (file-access? fname 2))
+;
+;(define (file-readable? fname)
+;  (file-access? fname 4))
+
+;;; (SET-FILE-TIMES path [access-time mod-time])
+
+(define (set-file-times path . maybe-times)
+  (with-resources-aligned 
+   (list cwd-resource euid-resource egid-resource) 
+   (lambda ()      
+     (if (pair? maybe-times)
+	 (let* ((access-time (real->exact-integer (car maybe-times)))
+		(mod-time (if (pair? (cddr maybe-times))
+			      (error "Too many arguments to set-file-times/errno"
+				     (cons path maybe-times))
+			      (real->exact-integer (cadr maybe-times)))))
+	   (%utime path access-time 
+		   mod-time ))
+	 (%utime-now path)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (truncate-file thing length)
+  (generic-file-op thing
+		   (lambda (fd)    (%truncate-fdes fd    length))
+		   (lambda (fname) (%truncate-file fname length))))
+
+(define (delete-file path)
+  (with-resources-aligned (list cwd-resource euid-resource egid-resource) 
+			  (lambda () (%delete-file path))))
+
+(define (sync-file fd/port)
+  (if (output-port? fd/port) (force-output fd/port))
+  (sleazy-call/fdes fd/port %sync-file))
+
+(define sync-file-system %sync-file-system)
+

scsh/fileinfo.scm

@@ -36,6 +36,53 @@
 ;;;
 ;;; Otherwise, signals an error.
 
+
+(define-record file-info
+  type
+  device
+  inode
+  mode
+  nlinks
+  uid
+  gid
+  size
+  atime
+  mtime
+  ctime
+  )
+
+;;; Should be redone to return multiple-values.
+(define (%file-info fd/port/fname chase?)
+  (let ((ans-vec (make-vector 11))
+	(file-type (lambda (type-code)
+		     (vector-ref '#(block-special char-special directory fifo
+						  regular socket symlink)
+				 type-code))))
+    (generic-file-op fd/port/fname
+		     (lambda (fd)
+		       (%stat-fdes fd ans-vec))
+		     (lambda (fname)
+		       (%stat-file fname ans-vec chase?)))
+    (make-file-info (file-type (vector-ref ans-vec 0))
+		    (vector-ref ans-vec 1)
+		    (vector-ref ans-vec 2)
+		    (vector-ref ans-vec 3)
+		    (vector-ref ans-vec 4)
+		    (vector-ref ans-vec 5)
+		    (vector-ref ans-vec 6)
+		    (vector-ref ans-vec 7)
+		    (vector-ref ans-vec 8)
+		    (vector-ref ans-vec 9)
+		    (vector-ref ans-vec 10))))
+						      
+		
+(define (file-info fd/port/fname . maybe-chase?)
+  (let ((chase? (:optional maybe-chase? #t)))
+    (%file-info fd/port/fname chase?)))
+
+(define file-attributes
+  (deprecated-proc file-info "file-attributes" "Use file-info instead."))
+
 (define (fd/port/fname-not-accessible? perms fd/port/fname)
   (with-errno-handler ((err data)
 		       ((errno/acces) 'search-denied)

scsh/filesys.scm

@@ -64,6 +64,11 @@
 
 ;;;;;;;
 
+(define (%create-directory path . maybe-mode)
+  (let ((mode (:optional maybe-mode #o777))
+	(fname (ensure-file-name-is-nondirectory path)))
+    (%%create-directory fname mode)))
+
 (define (create-directory dir . rest)
   (let ((perms (if (null? rest) #o777 (car rest)))
 	(override? (if (or (null? rest) (null? (cdr rest))) #f
@@ -120,6 +125,27 @@
 	 (lambda ()
 	   (%rename-file old-fname new-fname))))))
 
+(define (y-or-n? question . maybe-eof-value)
+  (let loop ((count *y-or-n-eof-count*))
+    (display question)
+    (display " (y/n)? ")
+    (let ((line (read-line)))
+      (cond ((eof-object? line)
+	     (newline)
+	     (if (= count 0)
+		 (:optional maybe-eof-value (error "EOF in y-or-n?"))
+		 (begin (display "I'll only ask another ")
+			(write count)
+			(display " times.")
+			(newline)
+			(loop (- count 1)))))
+	    ((< (string-length line) 1) (loop count))
+	    ((char=? (string-ref line 0) #\y) #t)
+	    ((char=? (string-ref line 0) #\n) #f)
+	    (else (loop count))))))
+
+(define *y-or-n-eof-count* 100)
+
 (define (read-symlink path)
   (with-resources-aligned 
 	 (list cwd-resource euid-resource egid-resource)

scsh/fname-system.scm

@@ -0,0 +1,71 @@
+;; user/group-dependent stuff
+
+(define (resolve-tilde-file-name fname)
+  (let ((len (string-length fname)))
+    (if (and (> len 0) (char=? #\~ (string-ref fname 0)))
+	(let ((tilde->homedir (lambda (end)
+				(if (= end 1)
+				    home-directory ; Just ~
+				    (let* ((user (substring fname 1 end))
+					   (ui (name->user-info user)))
+				      (user-info:home-dir ui))))))
+	  (cond ((string-index fname #\/ 1) =>
+		 (lambda (slash)
+		   (string-append (tilde->homedir slash) "/"
+				  (substring fname (+ slash 1) len))))
+		(else (tilde->homedir len))))
+	fname)))
+
+(define (resolve-file-name fname . maybe-root)
+  (let* ((root (ensure-file-name-is-nondirectory (:optional maybe-root ".")))
+	 (fname (ensure-file-name-is-nondirectory fname)))
+    (if (zero? (string-length fname))
+	"/"
+	(let ((c (string-ref fname 0)))
+	  (cond ((char=? #\/ c) fname) 	; Absolute file name.
+
+		((char=? #\~ c) 	; ~ file name
+		 (resolve-tilde-file-name fname))
+
+		(else (string-append (file-name-as-directory root) fname)))))))
+
+(define (expand-file-name fname . maybe-dir)
+  (simplify-file-name (apply resolve-file-name fname maybe-dir)))
+
+;; process-state-dependent stuff
+
+(define (absolute-file-name fname . maybe-root)
+  (let ((fname (ensure-file-name-is-nondirectory fname)))
+    (if (zero? (string-length fname))
+	"/"
+	(simplify-file-name
+	  (if (char=? #\/ (string-ref fname 0))
+	      fname 	; Absolute file name.
+	      (let ((root (:optional maybe-root (cwd))))
+		(string-append (file-name-as-directory root) fname)))))))
+
+;;; Ugh.
+(define (substitute-env-vars str)
+  (let lp ((ans '()) (s str))
+    (let ((len (string-length s)))
+      (cond
+        ((zero? len) (apply string-append (reverse! ans)))
+	((string-index s #\$) =>
+	 (lambda (i)
+	   (let ((ans (cons (substring s 0 i) ans))
+		 (s (substring s (+ i 1) len))
+		 (len (- len (+ i 1))))
+	     (if (zero? len)
+		 (lp ans "")
+		 (let ((next-char (string-ref s 0)))
+		   (cond ((char=? #\{ next-char)
+			  (cond ((string-index s #\}) =>
+				 (lambda (i)
+				   (lp (cons (getenv (substring s 1 i)) ans)
+				       (substring s (+ i 1) len))))
+				(else (error "Unbalanced ${ delimiter in string" s))))
+			 (else
+			  (let ((i (or (string-index s #\/) len)))
+			    (lp (cons (getenv (substring s 0 i)) ans)
+				(substring s i len))))))))))
+	(else (lp (cons s ans) ""))))))

scsh/fname.scm

@@ -151,37 +151,6 @@
 (define (replace-extension fname ext)
   (string-append (file-name-sans-extension fname) ext))
 
-
-(define (resolve-tilde-file-name fname)
-  (let ((len (string-length fname)))
-    (if (and (> len 0) (char=? #\~ (string-ref fname 0)))
-	(let ((tilde->homedir (lambda (end)
-				(if (= end 1)
-				    home-directory ; Just ~
-				    (let* ((user (substring fname 1 end))
-					   (ui (name->user-info user)))
-				      (user-info:home-dir ui))))))
-	  (cond ((string-index fname #\/ 1) =>
-		 (lambda (slash)
-		   (string-append (tilde->homedir slash) "/"
-				  (substring fname (+ slash 1) len))))
-		(else (tilde->homedir len))))
-	fname)))
-
-(define (resolve-file-name fname . maybe-root)
-  (let* ((root (ensure-file-name-is-nondirectory (:optional maybe-root ".")))
-	 (fname (ensure-file-name-is-nondirectory fname)))
-    (if (zero? (string-length fname))
-	"/"
-	(let ((c (string-ref fname 0)))
-	  (cond ((char=? #\/ c) fname) 	; Absolute file name.
-
-		((char=? #\~ c) 	; ~ file name
-		 (resolve-tilde-file-name fname))
-
-		(else (string-append (file-name-as-directory root) fname)))))))
-
-
 ;;; - Remove leading and internal occurrences of dot. A trailing dot
 ;;;   is left alone, in case the parent is a symlink.
 ;;; - Remove internal and trailing double-slashes. A leading double-slash
@@ -225,63 +194,6 @@
       (apply string-append ans))))
 
 
-(define (expand-file-name fname . maybe-dir)
-  (simplify-file-name (apply resolve-file-name fname maybe-dir)))
 
 
-(define (absolute-file-name fname . maybe-root)
-  (let ((fname (ensure-file-name-is-nondirectory fname)))
-    (if (zero? (string-length fname))
-	"/"
-	(simplify-file-name
-	  (if (char=? #\/ (string-ref fname 0))
-	      fname 	; Absolute file name.
-	      (let ((root (:optional maybe-root (cwd))))
-		(string-append (file-name-as-directory root) fname)))))))
 
-
-(define (home-dir . maybe-user)
-  (if (pair? maybe-user)
-      (let ((user (car maybe-user)))
-	(ensure-file-name-is-nondirectory
-	    (or (%homedir user)
-		(error "Cannot get user's home directory"
-		       user))))
-      home-directory))
-
-
-;;; (home-file [user] fname)
-
-(define (home-file arg1 . maybe-arg2)
-  (receive (dir fname)
-	   (if (pair? maybe-arg2)
-	       (values (home-dir arg1) (car maybe-arg2))
-	       (values home-directory  arg1))
-    (string-append (file-name-as-directory dir) fname)))
-
-
-;;; Ugh.
-(define (substitute-env-vars str)
-  (let lp ((ans '()) (s str))
-    (let ((len (string-length s)))
-      (cond
-        ((zero? len) (apply string-append (reverse! ans)))
-	((string-index s #\$) =>
-	 (lambda (i)
-	   (let ((ans (cons (substring s 0 i) ans))
-		 (s (substring s (+ i 1) len))
-		 (len (- len (+ i 1))))
-	     (if (zero? len)
-		 (lp ans "")
-		 (let ((next-char (string-ref s 0)))
-		   (cond ((char=? #\{ next-char)
-			  (cond ((string-index s #\}) =>
-				 (lambda (i)
-				   (lp (cons (getenv (substring s 1 i)) ans)
-				       (substring s (+ i 1) len))))
-				(else (error "Unbalanced ${ delimiter in string" s))))
-			 (else
-			  (let ((i (or (string-index s #\/) len)))
-			    (lp (cons (getenv (substring s 0 i)) ans)
-				(substring s i len))))))))))
-	(else (lp (cons s ans) ""))))))

scsh/import-os-error-syscall.scm

@@ -0,0 +1,30 @@
+(define-syntax import-os-error-syscall
+  (syntax-rules ()
+    ((import-os-error-syscall syscall (%arg ...) c-name)
+     (begin 
+       (import-lambda-definition syscall/eintr (%arg ...) c-name)
+       (define (syscall %arg ...)
+	 (let ((arg %arg) ...)
+	   (continuation-capture 
+	    (lambda (cont)
+	      (let loop ()
+		(with-handler
+		 (lambda (condition more)
+		   (if (and (exception? condition) (eq? (exception-reason condition) 
+							'os-error))
+		       (let ((stuff (exception-arguments condition)))
+			 (if (= (cadr stuff) errno/intr)
+			     (loop)
+			     (continuation-graft
+			      cont
+			      (lambda ()
+				(apply errno-error 
+				       (cadr stuff)   ; errno
+				       (caddr stuff)  ;msg
+				       syscall 
+				       (cdddr stuff)))))) ;packet
+		       (more)))
+		 (lambda ()
+		   (syscall/eintr %arg ...))))))))))))
+
+(import-os-error-syscall errno-msg (i) "errno_msg")

scsh/newports.scm

@@ -1037,3 +1037,34 @@
 				     (port/fdes->output-channel write-port)))
 			      ready-write-channels))
 		       write-list))))))
+
+;;; I/O
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define seek/set 0)			;Unix codes for "whence"
+(define seek/delta 1)
+(define seek/end 2)
+
+(define (seek fd/port offset . maybe-whence)
+  (let ((whence (:optional maybe-whence seek/set))
+	(fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
+    (%fd-seek fd offset whence)))
+
+(define (tell fd/port)
+  (let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
+    (%fd-seek fd 0 seek/delta)))
+
+(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
+    (with-resources-aligned 
+     (list cwd-resource umask-resource euid-resource egid-resource)
+     (lambda ()
+      (%open path flags (:optional maybe-mode #o666)))))
+
+(define (pipe)
+  (apply (lambda (r-fd w-fd)
+	   (let ((r (fdes->inport  r-fd))
+		 (w (fdes->outport w-fd)))
+	     (release-port-handle r)
+	     (release-port-handle w)
+	     (values r w)))
+	 (%pipe-fdes)))

scsh/port-collect.scm

@@ -0,0 +1,77 @@
+;;; Read characters from PORT until EOF, collect into a string.
+
+(define (port->string port)
+  (let ((sc (make-string-collector)))
+    (letrec ((lp (lambda ()
+		   (cond ((read-string 1024 port) =>
+			  (lambda (s)
+			    (collect-string! sc s)
+			    (lp)))
+			 (else (string-collector->string sc))))))
+      (lp))))
+
+;;; (loop (initial (sc (make-string-collector)))
+;;;       (bind (s (read-string 1024 port)))
+;;;       (while s)
+;;;       (do (collect-string! sc s))
+;;;       (result (string-collector->string sc)))
+
+;;; Read items from PORT with READER until EOF. Collect items into a list.
+
+(define (port->list reader port)
+  (let lp ((ans '()))
+    (let ((x (reader port)))
+      (if (eof-object? x) (reverse! ans)
+	  (lp (cons x ans))))))
+
+(define (port->sexp-list port)
+  (port->list read port))
+
+(define (port->string-list port)
+  (port->list read-line port))
+
+(define (port-fold port reader op . seeds)
+  (letrec ((fold (lambda seeds
+		     (let ((x (reader port)))
+		       (if (eof-object? x) (apply values seeds)
+			   (call-with-values (lambda () (apply op x seeds))
+					     fold))))))
+    (apply fold seeds)))
+
+(define reduce-port
+  (deprecated-proc port-fold 'reduce-port "Use port-fold instead."))
+
+;;; Not defined:
+;;; (field-reader field-delims record-delims)
+;;; Returns a reader that reads strings delimited by 1 or more chars from
+;;; the string FIELD-DELIMS. These strings are collected in a list until
+;;; eof or until 1 or more chars from RECORD-DELIMS are read. Then the
+;;; accumulated list of strings is returned. For example, if we want
+;;; a procedure that reads one line of input, splitting it into 
+;;; whitespace-delimited strings, we can use 
+;;;     (field-reader " \t" "\n")
+;;; for a reader.
+
+
+
+;; Loop until EOF reading characters or strings and writing (FILTER char)
+;; or (FILTER string). Useful as an arg to FORK or FORK/PIPE.
+
+(define (make-char-port-filter filter)
+  (lambda ()
+    (let lp ()
+      (let ((c (read-char)))
+	(if (not (eof-object? c))
+	    (begin (write-char (filter c))
+		   (lp)))))))
+
+(define (make-string-port-filter filter . maybe-buflen)
+  (let* ((buflen (:optional maybe-buflen 1024))
+	 (buf (make-string buflen)))
+    (lambda ()
+      (let lp ()
+	(cond ((read-string! buf 0 buflen) =>
+	       (lambda (nread)
+		 (display (filter (if (= nread buflen) buf
+				      (substring buf 0 nread)))) ; last one.
+		 (lp))))))))

scsh/process-high-level.scm

@@ -0,0 +1,123 @@
+;;;; Process->Scheme interface forms: run/collecting, run/port, run/string, ...
+
+;;; (run/collecting FDS . EPF)
+;;; --------------------------
+;;; RUN/COLLECTING and RUN/COLLECTING* run processes that produce multiple
+;;; output streams and return ports open on these streams.
+;;;
+;;; To avoid issues of deadlock, RUN/COLLECTING first runs the process
+;;; with output to temp files, then returns the ports open on the temp files.
+;;;
+;;; (run/collecting (1 2) (ls))
+;;; runs ls with stdout (fd 1) and stderr (fd 2) redirected to temporary files.
+;;; When ls is done, RUN/COLLECTING returns two ports open on the temporary
+;;; files. The files are deleted before RUN/COLLECTING returns, so when
+;;; the ports are closed, they vanish.
+;;;
+;;; The FDS list of file descriptors is implicitly backquoted.
+;;;
+;;; RUN/COLLECTING* is the procedural abstraction of RUN/COLLECTING.
+
+(define (run/collecting* fds thunk)
+  ;; First, generate a pair of ports for each communications channel.
+  ;; Each channel buffers through a temp file.
+  (let* ((channels (map (lambda (ignore)
+			  (call-with-values temp-file-channel cons))
+		       fds))
+	 (read-ports (map car channels))
+	 (write-ports (map cdr channels))
+
+	 ;; In a subprocess, close the read ports, redirect input from
+	 ;; the write ports, and run THUNK.
+	 (status (run (begin (for-each close-input-port read-ports)
+			     (for-each move->fdes write-ports fds)
+			     (thunk)))))
+
+    ;; In this process, close the write ports and return the exit status
+    ;; and all the the read ports.
+    (for-each close-output-port write-ports)
+    (apply values status read-ports)))
+
+
+;;; Single-stream collectors:
+;;; Syntax: run/port, run/file, run/string, run/strings, run/sexp, run/sexps
+;;; Procedures: run/port*, run/file*, run/string*, run/strings*, run/sexp*,
+;;;             run/sexps*
+;;;             port->string, port->string-list, port->sexp-list, 
+;;;             port->list
+;;; 
+;;; Syntax:
+;;; (run/port . epf)
+;;; 	Fork off the process EPF and return a port on its stdout.
+;;; (run/file . epf)
+;;; 	Run process EPF with stdout redirected into a temp file.
+;;;     When the process exits, return the name of the file.
+;;; (run/string . epf)
+;;;     Read the process' stdout into a string and return it.
+;;; (run/strings . epf)
+;;; 	Run process EPF, reading newline-terminated strings from its stdout
+;;;     until EOF. After process exits, return list of strings read. Delimiting
+;;;	newlines are trimmed from the strings.
+;;; (run/sexp . epf)
+;;;     Run process EPF, read and return one sexp from its stdout with READ.
+;;; (run/sexps . epf)
+;;;     Run process EPF, read sexps from its stdout with READ until EOF.
+;;;	After process exits, return list of items read.
+;;;
+;;; Procedural abstractions:
+;;; run/port*, run/file*, run/string*, run/strings*, run/sexp*, run/sexps*
+;;;
+;;; These are all procedural equivalents for the macros. They all take
+;;; one argument: the process to be executed passed as a thunk. For example,
+;;; (RUN/PORT . epf) expands into (RUN/PORT* (LAMBDA () (EXEC-EPF . epf)))
+;;;
+;;; Other useful procedures:
+;;; 
+;;; (port->string port) 
+;;; 	Read characters from port until EOF; return string collected.
+;;; (port->string-list port)
+;;;     Read newline-terminated strings from port until EOF. Return
+;;;     the list of strings collected.
+;;; (port->sexp-list port)
+;;;     Read sexps from port with READ until EOF. Return list of items read.
+;;; (port->list reader port)
+;;;     Repeatedly applies READER to PORT, accumulating results into a list.
+;;;     On EOF, returns the list of items thus collected.
+;;; (port-fold port reader op . seeds)
+;;;     Repeatedly read things from PORT with READER. Each time you read
+;;;     some value V, compute a new set of seeds with (apply OP V SEEDS).
+;;;     (More than 1 seed means OP must return multiple values).
+;;;     On eof, return the seeds: (apply value SEEDS).
+;;;     PORT->LIST is just (PORT-FOLD PORT READ CONS '())
+
+(define (run/port+proc* thunk)
+  (receive (r w) (pipe)
+    (let ((proc (fork (lambda ()
+			(close r)
+			(move->fdes w 1)
+			(with-current-output-port* w thunk)))))
+      (close w)
+      (values r proc))))
+
+(define (run/port* thunk)
+  (receive (port proc) (run/port+proc* thunk)
+    port))
+
+(define (run/file* thunk)
+  (let ((fname (create-temp-file)))
+    (run (begin (thunk)) (> ,fname))
+    fname))
+
+(define (run/string* thunk) 
+  (close-after (run/port* thunk) port->string))
+
+(define (run/sexp* thunk)
+  (close-after (run/port* thunk) read))
+
+(define (run/sexps* thunk)
+  (close-after (run/port* thunk) port->sexp-list))
+
+(define (run/strings* thunk)
+  (close-after (run/port* thunk) port->string-list))
+
+

scsh/process-state.scm

@@ -0,0 +1,321 @@
+;;; UMASK
+
+(import-os-error-syscall set-process-umask (mask) "scsh_umask")
+
+(define (process-umask)
+  (let ((m (set-process-umask 0)))
+    (set-process-umask m)
+    m))
+;;; Working directory
+
+(import-os-error-syscall %chdir (directory) "scsh_chdir")
+
+;;; These calls change/reveal the process working directory
+;;; 
+
+(define (process-chdir . maybe-dir)
+  (let ((dir (:optional maybe-dir (home-dir))))
+    (%chdir dir)))
+
+;; TODO: we get an error if cwd does not exist on startup
+(import-os-error-syscall process-cwd () "scheme_cwd")
+
+;;; GID
+
+(import-os-error-syscall user-gid  () "scsh_getgid")
+
+(import-os-error-syscall process-user-effective-gid () "scsh_getegid")
+
+(import-os-error-syscall process-set-gid (gid) "scsh_setgid")
+
+(import-os-error-syscall set-process-user-effective-gid (gid) "scsh_setegid")
+
+(import-os-error-syscall user-supplementary-gids () "get_groups")
+
+;;; UID
+(import-os-error-syscall user-uid  () "scsh_getuid")
+
+(import-os-error-syscall process-user-effective-uid () "scsh_geteuid")
+
+(import-os-error-syscall process-set-uid (uid) "scsh_setuid")
+
+(import-os-error-syscall set-process-user-effective-uid (uid) "scsh_seteuid")
+
+(import-os-error-syscall %user-login-name () "my_username")
+ 
+(define (user-login-name)
+  (or (%user-login-name)
+      (error "Cannot get your name")))
+
+
+;;; PID
+
+(import-os-error-syscall pid () "scsh_getpid")
+(import-os-error-syscall parent-pid () "scsh_getppid")
+;;; Process groups and session ids
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(import-os-error-syscall process-group () "scsh_getpgrp")
+
+(import-os-error-syscall %set-process-group (pid groupid) "scsh_setpgid")
+
+(define (set-process-group arg1 . maybe-arg2)
+  (receive (pid pgrp) (if (null? maybe-arg2)
+			  (values (pid) arg1)
+			  (values arg1 (car maybe-arg2)))
+	   (%set-process-group pid pgrp)))
+
+
+(import-os-error-syscall become-session-leader () "scsh_setsid")
+
+;;; Miscellaneous process state
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; PROCESS TIMES
+
+;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
+
+
+(import-os-error-syscall process-times/list () "process_times")
+
+(define (process-times)
+  (apply values (process-times/list)))
+
+(import-os-error-syscall cpu-ticks/sec () "cpu_clock_ticks_per_sec")
+
+;;; Resources
+
+;; Align the value of the Unix cwd with scsh's value.
+;; Since another thread could disalign, this call and
+;; any ensuring syscall that relies upon it should
+;; be "glued together" with the cwd lock.
+
+(define cwd-lock (make-lock))
+
+(define (align-cwd!)
+  (let ((thread-cwd (cwd)))
+    (if (not (string=? thread-cwd (cwd-cache)))
+	(change-and-cache-cwd thread-cwd))))
+
+(define cwd-resource (make-resource align-cwd! cwd-lock))
+
+;; example syscall
+;; (define (exported-delete-file fname)
+;;  (with-cwd-aligned (really-delete-file fname)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; effective uid and gid per thread
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; working directory per thread
+
+(define *cwd-cache* 'uninitialized)
+
+(define (initialize-cwd)
+  (set! *cwd-cache* (process-cwd))
+  (set! $cwd ;;; TODO The old thread-fluid will remain
+	(make-preserved-thread-fluid
+	 (cwd-cache))))
+;  (set! cwd-lock (make-lock)))
+
+(define (cwd-cache)
+  *cwd-cache*)
+
+;; Actually do the syscall and update the cache
+;; assumes the cwd lock obtained
+(define (change-and-cache-cwd new-cwd)
+  (if (not (file-name-absolute? new-cwd))
+      (process-chdir (string-append (cwd) "/" new-cwd))
+      (process-chdir new-cwd))
+  (set! *cwd-cache* (process-cwd)))
+
+;; The thread-specific cwd: A thread fluid
+
+(define $cwd 'empty-cwd-value)
+
+(define (cwd) (thread-fluid $cwd))
+(define (thread-set-cwd! cwd) (set-thread-fluid! $cwd cwd))
+(define (let-cwd cwd thunk)
+  (let-thread-fluid $cwd cwd thunk))
+
+(define (with-cwd* new-cwd thunk)
+  (let ((changed-cwd
+	 (with-lock cwd-lock
+	   (lambda ()
+	     (change-and-cache-cwd new-cwd)
+	     (cwd-cache)))))
+    (let-cwd changed-cwd thunk)))
+
+(define (chdir . maybe-dir)
+  (let ((dir (:optional maybe-dir (home-dir))))
+    (with-lock cwd-lock
+      (lambda ()
+	(change-and-cache-cwd dir)
+	(thread-set-cwd! (cwd-cache))))))
+
+(define cwd-reinitializer
+  (make-reinitializer (lambda () (initialize-cwd))))
+
+(initialize-cwd)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; umask per thread
+(define *umask-cache* 'uninitialized)
+(define umask-lock (make-lock))
+
+(define (initialize-umask)
+  (set! *umask-cache* (process-umask))
+  (set! $umask ;;; TODO The old thread-fluid will remain
+	(make-preserved-thread-fluid
+	 (umask-cache))))
+;  (set! umask-lock (make-lock)))
+
+(define (umask-cache)
+  *umask-cache*)
+
+;; Actually do the syscall and update the cache
+;; assumes the resource lock obtained
+(define (change-and-cache-umask new-umask)
+  (set-process-umask new-umask)
+  (set! *umask-cache* (process-umask)))
+
+;; The thread-specific umask: A thread fluid
+
+(define $umask 'empty-umask-value)
+
+(define (umask) (thread-fluid $umask))
+(define (thread-set-umask! new-umask) (set-thread-fluid! $umask new-umask))
+(define (let-umask new-umask thunk)
+  (let-thread-fluid $umask new-umask thunk))
+
+(define (with-umask* new-umask thunk)
+  (let ((changed-umask
+	 (with-lock umask-lock
+	   (lambda ()
+	     (change-and-cache-umask new-umask)
+	     (umask-cache)))))
+    (let-umask changed-umask thunk)))
+
+(define (align-umask!)
+  (let ((thread-umask (umask)))
+    (if (not (= thread-umask (umask-cache)))
+	(change-and-cache-umask thread-umask))))
+
+(define (set-umask new-umask)
+  (with-lock umask-lock
+    (lambda ()
+      (change-and-cache-umask new-umask)
+      (thread-set-umask! (umask-cache)))))
+
+(define umask-resource (make-resource align-umask! umask-lock))
+
+(define umask-reinitializer
+  (make-reinitializer (lambda () (initialize-umask))))
+
+
+(initialize-umask)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ensure S48 is aligned too
+
+(set-with-fs-context-aligned*! 
+ (lambda (thunk)
+   (with-resources-aligned 
+    (list cwd-resource umask-resource euid-resource egid-resource) 
+    thunk)))
+
+;; 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-user-effective-uid uid . body)
+  (with-user-effective-uid* uid (lambda () . body)))
+
+(define-simple-syntax (with-user-effective-gid gid . body)
+  (with-user-effective-gid* gid (lambda () . body)))
+
+(define-syntax make-Xid-resource 
+  (syntax-rules ()
+    ((make-Xid-resource 
+      process-user-effective-Xid set-process-user-effective-Xid
+      process-set-Xid set-Xid
+      align-eXid! eXid-resource
+      user-effective-Xid set-user-effective-Xid with-user-effective-Xid*)
+     (begin
+       (define *eXid-cache* 'uninitialized)
+       (define eXid-lock (make-lock))
+     
+       (define (initialize-eXid)
+	 (set! *eXid-cache* (process-user-effective-Xid))
+	 (set! $eXid
+	       (make-preserved-thread-fluid
+		(eXid-cache))))
+
+       (define (eXid-cache)
+	 *eXid-cache*)
+
+;; Actually do the syscall and update the cache
+;; assumes the resource lock obtained
+       (define (change-and-cache-eXid new-eXid)
+	 (set-process-user-effective-Xid new-eXid)
+	 (set! *eXid-cache* (process-user-effective-Xid)))
+
+;; The thread-specific eXid: A thread fluid
+
+       (define $eXid 'empty-eXid-value)
+
+       (define (user-effective-Xid) (thread-fluid $eXid))
+       (define (thread-set-eXid! new-eXid) (set-thread-fluid! $eXid new-eXid))
+       (define (let-eXid new-eXid thunk)
+	 (let-thread-fluid $eXid new-eXid thunk))
+
+;; set-Xid will affect the effective X id
+       (define (set-Xid Xid)
+	 (with-lock eXid-lock
+	   (lambda ()
+	     (process-set-Xid Xid)
+	     (set! *eXid-cache* (process-user-effective-Xid))
+	     (thread-set-eXid! *eXid-cache*))))
+
+       (define (with-user-effective-Xid* new-eXid thunk)
+	 (let ((changed-eXid
+		(with-lock eXid-lock
+		  (lambda ()
+		    (change-and-cache-eXid new-eXid)
+		    (eXid-cache)))))
+	   (let-eXid changed-eXid thunk)))
+
+       (define (align-eXid!)
+	 (let ((thread-eXid (user-effective-Xid)))
+	   (if (not (= thread-eXid (eXid-cache)))
+	       (change-and-cache-eXid thread-eXid))))
+
+       (define (set-user-effective-Xid new-eXid)
+	 (with-lock eXid-lock
+	   (lambda ()
+	     (change-and-cache-eXid new-eXid)
+	     (thread-set-eXid! (eXid-cache)))))
+
+       (define eXid-resource (make-resource align-eXid! eXid-lock))
+
+       (define eXid-reinitializer
+	 (make-reinitializer (lambda () (initialize-eXid))))
+
+       (initialize-eXid)
+       ))))
+
+(make-Xid-resource 
+ process-user-effective-uid set-process-user-effective-uid
+ process-set-uid set-uid
+ align-euid! euid-resource
+ user-effective-uid set-user-effective-uid with-user-effective-uid*)
+
+(make-Xid-resource 
+ process-user-effective-gid set-process-user-effective-gid
+ process-set-gid set-gid
+ align-egid! egid-resource
+ user-effective-gid set-user-effective-gid with-user-effective-gid*)

scsh/process.scm

@@ -0,0 +1,331 @@
+
+;;; Process
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; we can't algin env here, because exec-path/env calls
+;; %%exec/errno directly  F*&% *P
+(import-os-error-syscall %%exec (prog argv env) "scheme_exec")
+
+(define (%exec prog arg-list env)
+  (let ((argv (mapv! stringify (list->vector arg-list)))
+	(prog (stringify prog))
+	(env (if (eq? env #t) #t (alist->env-vec env))))
+    (%%exec prog argv env)))
+
+
+(import-os-error-syscall exit/errno ; errno -- misnomer.
+  (status) "scsh_exit")
+
+(import-os-error-syscall %exit/errno ; errno -- misnomer
+  (status) "scsh__exit")
+
+(define (%exit . maybe-status)
+  (%exit/errno (:optional maybe-status 0))
+  (error "Yikes! %exit returned."))
+
+(import-os-error-syscall %%fork () "scsh_fork")
+
+;;; EXEC support
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Assumes a low-level %exec procedure:
+;;; (%exec prog arglist env)
+;;;   ENV is either #t, meaning the current environment, or a string->string
+;;;       alist.
+;;;   %EXEC stringifies PROG and the elements of ARGLIST.
+
+(define (exec-path-search prog path-list)
+  (cond
+   ((not (file-name-absolute? prog))
+    (let loop ((path-list path-list))
+      (if (not (null? path-list))
+	  (let* ((dir (car path-list))
+		 (fname (string-append dir "/" prog)))
+	    (if (file-executable? fname)
+		fname
+		(loop (cdr path-list)))))))
+   ((file-executable? prog)
+    prog)
+   (else #f)))
+
+(define (exec/env prog env . arglist)
+  (flush-all-ports)
+  (with-resources-aligned 
+   (list environ-resource cwd-resource umask-resource euid-resource egid-resource)
+   (lambda ()
+     (%exec prog (cons prog arglist) env))))
+
+;;; Some globals:
+(define exec-path-list)
+
+(define (init-exec-path-list quietly?)
+  (set! exec-path-list
+	(make-preserved-thread-fluid 
+	 (cond ((getenv "PATH") => split-colon-list)
+	       (else (if (not quietly?)
+			 (warn "Starting up with no path ($PATH)."))
+		     '())))))
+
+;;; We keep SPLIT-COLON-LIST defined internally so the top-level
+;;; startup code (INIT-SCSH) can use it to split up $PATH without
+;;; requiring the field-splitter or regexp code.
+
+(define (split-colon-list clist)
+  (let ((len (string-length clist)))
+    (if (= 0 len) '()			; Special case "" -> ().
+
+	;; Main loop.
+	(let split ((i 0))
+	  (cond ((string-index clist #\: i) =>
+		 (lambda (colon)
+		   (cons (substring clist i colon)
+			 (split (+ colon 1)))))
+		(else (list (substring clist i len))))))))
+
+;(define (exec-path/env prog env . arglist)
+;  (cond ((exec-path-search (stringify prog) (fluid exec-path-list)) =>
+;	 (lambda (binary)
+;	   (apply exec/env binary env arglist)))
+;	(else (error "No executable found." prog arglist))))
+
+;;; This procedure is bummed by tying in directly to %%exec/errno
+;;; and pulling some of %exec's code out of the inner loop so that
+;;; the inner loop will be fast. Folks don't like waiting...
+
+(define (exec-path/env prog env . arglist)
+  (flush-all-ports)
+  (with-resources-aligned 
+   (list environ-resource cwd-resource umask-resource euid-resource egid-resource)
+   (lambda ()
+     (let ((prog (stringify prog)))
+       (if (string-index prog #\/)
+		 
+	   ;; Contains a slash -- no path search.
+	   (%exec prog (cons prog arglist) env)
+		 
+	   ;; Try each directory in PATH-LIST.
+	   (let ((argv (list->vector (cons prog (map stringify arglist)))))
+	     (for-each (lambda (dir)
+			 (let ((binary (string-append dir "/" prog)))
+			   (%%exec binary argv env)))
+		       (thread-fluid exec-path-list)))))
+	   
+     (error "No executable found." prog arglist))))
+   
+(define (exec-path prog . arglist)
+  (apply exec-path/env prog #t arglist))
+
+(define (exec prog . arglist)
+  (apply exec/env prog #t arglist))
+
+
+;;; Assumes niladic primitive %%FORK.
+
+(define (fork . stuff)
+  (apply fork-1 #t stuff))
+
+(define (%fork . stuff)
+  (apply fork-1 #f stuff))
+
+(define (fork-1 clear-interactive? . rest)
+  (let-optionals rest ((maybe-thunk #f)
+		       (dont-narrow? #f))
+    (really-fork clear-interactive?
+		 (not dont-narrow?)
+		 maybe-thunk)))
+
+(define (preserve-ports thunk)
+  (let ((current-input (current-input-port))
+	(current-output (current-output-port))
+	(current-error (current-error-port)))
+    (lambda ()
+      (with-current-input-port*
+       current-input
+       (lambda ()
+	 (with-current-output-port*
+	  current-output
+	  (lambda ()
+	    (with-current-error-port*
+	     current-error
+	     thunk))))))))
+
+(define (really-fork clear-interactive? narrow? maybe-thunk)
+  (let ((proc #f)
+	(maybe-narrow
+	 (if narrow?
+	     (lambda (thunk)
+	       ;; narrow loses the thread fluids and the dynamic environment
+	       (narrow (preserve-ports (preserve-thread-fluids thunk))
+		       'forking))
+	     (lambda (thunk) (thunk)))))
+    (maybe-narrow
+     (lambda ()
+
+       (if clear-interactive?
+	   (flush-all-ports))
+
+       ;; There was an atomicity problem/race condition -- if a child
+       ;; process died after it was forked, but before the scsh fork
+       ;; procedure could register the child's procobj in the
+       ;; pid/procobj table, then when the SIGCHLD signal-handler reaped
+       ;; the process, there would be no procobj for it.  We now lock
+       ;; out interrupts across the %%FORK and NEW-CHILD-PROC
+       ;; operations.
+
+       (((structure-ref interrupts with-interrupts-inhibited)
+	 (lambda ()
+	   ;; with-env-aligned is not neccessary here but it will
+	   ;; create the environ object in the parent process which
+	   ;; could reuse it on further forks
+	   (let ((pid (with-resources-aligned 
+		       (list environ-resource)
+		       %%fork)))
+	     (if (zero? pid)				
+		 ;; Child
+		 (lambda ()		; Do all this outside the WITH-INTERRUPTS.
+		   ;; There is no session if parent was started in batch-mode
+		   (if (and (session-started?) clear-interactive?)
+		       (set-batch-mode?! #t)) ; Children are non-interactive.
+		   (if maybe-thunk
+		       (call-and-exit maybe-thunk)))
+		 ;; Parent
+		 (begin
+		   (set! proc (new-child-proc pid))
+		   (lambda ()
+		     (values))))))))))
+    proc))
+
+(define (exit . maybe-status)
+  (let ((status (:optional  maybe-status 0)))
+    (if (not (integer? status))
+        (error "non-integer argument to exit"))
+    (call-exit-hooks-and-narrow
+     (lambda ()
+       (exit/errno status)
+       (display "The evil undead walk the earth." 2)
+       (if #t (error "(exit) returned."))))))
+
+
+(define (call-and-exit thunk)
+  (call-terminally
+   (lambda ()
+     (dynamic-wind
+      values
+      thunk
+      (lambda () (exit 0))))))
+
+;;; Like FORK, but the parent and child communicate via a pipe connecting
+;;; the parent's stdin to the child's stdout. This function side-effects
+;;; the parent by changing his stdin.
+
+(define (fork/pipe . stuff)
+  (really-fork/pipe fork stuff))
+
+(define (%fork/pipe . stuff)
+  (really-fork/pipe %fork stuff))
+  
+;;; Common code for FORK/PIPE and %FORK/PIPE.
+(define (really-fork/pipe forker rest)
+  (let-optionals rest ((maybe-thunk #f)
+		       (no-new-command-level? #f))
+    (receive (r w) (pipe)
+      (let ((proc (forker #f no-new-command-level?)))
+	(cond (proc		; Parent
+	       (close w)
+	       (move->fdes r 0))
+	      (else		; Child
+	       (close r)
+	       (move->fdes w 1)
+	       (if maybe-thunk
+		   (call-and-exit maybe-thunk))))
+	proc))))
+
+
+;;; FORK/PIPE with a connection list.
+;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t)
+
+(define (%fork/pipe+ conns . stuff)
+  (really-fork/pipe+ %fork conns stuff))
+
+(define (fork/pipe+ conns . stuff)
+  (really-fork/pipe+ fork conns stuff))
+
+;;; Common code.
+(define (really-fork/pipe+ forker conns rest)
+  (let-optionals rest ((maybe-thunk #f)
+		       (no-new-command-level? #f))
+    (let* ((pipes (map (lambda (conn) (call-with-values pipe cons))
+		       conns))
+	   (rev-conns (map reverse conns))
+	   (froms (map (lambda (conn) (reverse (cdr conn)))
+		       rev-conns))
+	   (tos (map car rev-conns)))
+
+      (let ((proc (forker #f no-new-command-level?)))
+	(cond (proc			; Parent
+	       (for-each (lambda (to r/w)
+			   (let ((w (cdr r/w))
+				 (r (car r/w)))
+			     (close w)
+			     (move->fdes r to)))
+			 tos pipes))
+
+	      (else			; Child
+	       (for-each (lambda (from r/w)
+			   (let ((r (car r/w))
+				 (w (cdr r/w)))
+			     (close r)
+			     (for-each (lambda (fd) (dup w fd)) from)
+			     (close w))) ; Unrevealed ports win.
+			 froms pipes)
+	       (if maybe-thunk
+		   (call-and-exit maybe-thunk))))
+	proc))))
+
+(define (tail-pipe a b)
+  (fork/pipe a)
+  (call-and-exit b))
+
+(define (tail-pipe+ conns a b)
+  (fork/pipe+ conns a)
+  (call-and-exit b))
+
+;;; Lay a pipeline, one process for each thunk. Last thunk is called
+;;; in this process. PIPE* never returns.
+
+(define (pipe* . thunks)
+  (letrec ((lay-pipe (lambda (thunks)
+		       (let ((thunk (car thunks))
+			     (thunks (cdr thunks)))
+			 (if (pair? thunks)
+			     (begin (fork/pipe thunk)
+				    (lay-pipe thunks))
+			     (call-and-exit thunk)))))) ; Last one.
+    (if (pair? thunks)
+	(lay-pipe thunks)
+	(error "No thunks passed to PIPE*"))))
+
+;;; The classic T 2.0 primitive.
+;;; This definition works for procedures running on top of Unix systems.
+(define (halts? proc) #t)
+
+; SIGTSTP blows s48 away. ???
+(define (suspend) (signal-process 0 signal/stop))
+
+
+;;; Miscellaneous
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; usleep(3): Try to sleep for USECS microseconds.
+;;; sleep(3):  Try to sleep for SECS seconds.
+
+; De-released -- not POSIX and not on SGI systems.
+; (define-foreign usleep (usleep (integer usecs)) integer)
+
+(define (process-sleep secs) (process-sleep-until (+ secs (time))))
+
+(define (process-sleep-until when)
+  (let* ((when (floor when))	; Painful to do real->int in Scheme.
+	 (when (if (exact? when) when (inexact->exact when))))
+    (let lp ()
+      (or (%sleep-until when) (lp)))))
+
+(import-os-error-syscall %sleep-until (secs) "sleep_until")

scsh/procobj.scm

@@ -331,7 +331,11 @@
 	 (else (error "mismatch in really-wait" 
 		      return_pid pid)))))
   
+;;; Posix waitpid(2) call.
+(import-os-error-syscall %wait-pid/list (pid options) "wait_pid")
 
+(define (%wait-pid pid options)
+  (apply values (%wait-pid/list pid options)))
 
 ;;; All you have to do, if pid was reaped
 ;;; proc_obj is maybe no longer alive

scsh/resource.scm

@@ -0,0 +1,19 @@
+(define-record-type resource :resource
+  (make-resource align! lock)
+  resource?
+  (align! resource-align!)
+  (lock resource-lock))
+
+(define (with-resources-aligned resources thunk)
+   (let ((locks (map resource-lock resources)))
+     (apply obtain-all-or-none locks)
+     (for-each
+      (lambda (align!) (align!))
+      (map resource-align! resources))
+     (let ((val (with-handler
+		 (lambda (cond more)
+		   (for-each release-lock locks)
+		   (more))
+		 thunk)))
+       (for-each release-lock locks)
+       val)))

scsh/rw.scm

@@ -3,12 +3,6 @@
 
 ;;; Note: read ops should check to see if their string args are mutable.
 
-(define (bogus-substring-spec? s start end)
-  (or (< start 0)
-      (< (string-length s) end)
-      (< end start)))
-
-
 ;;; Best-effort/forward-progress reading 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

scsh/scsh-interfaces.scm

@@ -101,13 +101,132 @@
 				     :values))
 	  (with-errno-handler :syntax)))
 
+(define-interface scsh-continuations-interface
+  (export continuation-capture
+	  continuation-graft
+	  continuation-return
+	  call-terminally))
 
+(define-interface scsh-import-os-error-syscalls-interface
+  (export (import-os-error-syscall :syntax)
+	  errno-msg))
+
+(define-interface scsh-file-syscalls-interface
+  (export %set-cloexec
+	  %fcntl-read  %fcntl-write
+	  %open %close-fdes %dup %dup2 %pipe-fdes
+	  %fd-seek
+	  %char-ready-fdes?
+	  %truncate-file %truncate-fdes 
+	  %create-symlink %read-symlink
+	  %delete-file %rename-file
+	  %%create-directory %delete-directory
+	  %create-hard-link
+	  %create-fifo
+	  %set-file-mode %set-fdes-mode
+	  %set-file-uid&gid %set-fdes-uid&gid
+	  %utime %utime-now
+	  %stat-file %stat-fdes
+	  %sync-file %sync-file-system
+	  %open-dir))
 
 (define buffered-io-flags-interface
   (export ((bufpol/block
 	    bufpol/line
 	    bufpol/none) :number)))
 
+(define-interface scsh-newports-interface
+  (export call/fdes
+	  sleazy-call/fdes
+	  fdes->inport
+	  set-port-buffering
+	  fdes->outport
+	  evict-ports
+	  fdport?
+	  %move-fdport
+	  close-fdes
+	  make-input-fdport
+	  make-output-fdport
+	  open-fdes
+	  fdport-data:fd
+	  close
+	  fdport-data
+	  select
+	  fdport-data:channel
+	  seek/set
+	  open-file
+	  pipe
+	  with-current-output-port*
+	  close-after
+	  set-current-input-port!
+	  set-current-output-port!
+	  set-current-error-port!
+	  with-current-error-port
+	  with-current-output-port
+	  with-current-input-port
+	  flush-all-ports
+	  with-current-error-port*
+	  with-current-input-port*
+	  close-after
+	  with-current-error-port
+	  with-current-output-port
+	  flush-all-ports
+	  error-output-port
+	  close
+	  release-port-handle
+	  flush-all-ports-no-threads
+	  select!
+	  set-error-output-port!
+	  with-error-output-port*
+	  release-port-handle
+	  seek/end
+	  port-revealed
+	  select-port-channels
+	  with-error-output-port
+	  init-fdports!
+	  seek/delta
+	  tell
+	  seek
+	  init-fdports!
+	  port->fdes select-ports
+
+	  char-ready?
+	  read-char
+	  display write newline write-char
+	  force-output
+	  open-input-file
+	  with-output-to-file with-input-from-file
+	  call-with-input-file call-with-output-file
+	  open-output-file))
+
+(define-interface scsh-fcntl-interface
+  (export fdes-flags set-fdes-flags
+	  fdes-status set-fdes-status))
+
+(define-interface scsh-read/write-interface
+  (export read-string/partial
+	  read-string!/partial
+	  read-string read-string!
+	  write-string
+	  write-string/partial))
+
+(define-interface scsh-flock-interface
+  (export lock-region?
+	  lock-region:exclusive?
+	  lock-region:whence
+	  lock-region:start
+	  lock-region:len
+	  lock-region:pid		; Deprecated proc.
+	  lock-region:proc
+	  make-lock-region
+
+	  lock-region
+	  lock-region/no-block
+	  get-lock-region
+	  unlock-region
+	  with-region-lock*
+	  (with-region-lock :syntax)))
+
 (define-interface scsh-io-interface
   (compound-interface buffered-io-flags-interface
 		      (export close
@@ -126,7 +245,6 @@
 			      set-fdes-status
 
 			      init-fdports!  ;added by JMG
-			      port->channel  ;overwrites channel-i/o
 
 			      force-output
 			      set-port-buffering
@@ -142,8 +260,6 @@
 
 			      flush-all-ports
 			      flush-all-ports-no-threads
-			      y-or-n?
-			      *y-or-n-eof-count*
 			      ;; R4RS I/O procedures that scsh provides.
 			      write
 			      char-ready?
@@ -301,40 +417,24 @@
 	  file-exists?
 
 	  sync-file
-	  sync-file-system
+	  sync-file-system))
 
-	  open-directory-stream
-	  close-directory-stream
-	  read-directory-stream
-	  
-	  directory-files
-	  glob
+(define-interface scsh-globbing-interface
+  (export glob
 	  glob-quote
-	  file-match
+	  maybe-directory-files))
 
-	  create-temp-file
+(define-interface scsh-file-matching-interface
+  (export file-match))
+
+(define-interface scsh-temp-files-interface
+  (export create-temp-file
 	  temp-file-iterate
 	  temp-file-channel
 	  *temp-file-template*))
 
-
-(define-interface scsh-process-interface
-  (export exec
-	  exec-path
-	  exec/env
-	  exec-path/env
-	  %exec
-	  exec-path-search
-
-	  exit
-	  %exit
-
-	  suspend
-
-	  fork
-	  %fork
-
-	  proc?
+(define-interface scsh-process-objects-interface
+  (export proc?
 	  proc:pid
 	  pid->proc
 
@@ -352,12 +452,45 @@
 	  wait/poll
 	  wait/stopped-children
 
+	  new-child-proc))
+
+(define-interface scsh-processes-interface
+  (export exec
+	  exec-path
+	  exec/env
+	  exec-path/env
+	  %exec
+	  exec-path-search
+
+	  exit
+	  %exit
+
+	  suspend
+
+	  fork
+	  %fork
+
 	  process-sleep
 	  process-sleep-until
 
 	  call-terminally
-	  halts?))
+	  halts?
 
+	  fork/pipe
+	  %fork/pipe
+	  fork/pipe+
+	  %fork/pipe+
+	  tail-pipe
+	  tail-pipe+
+	  
+	  init-exec-path-list)) ; ### should be internal
+
+(define-interface scsh-fdports-interface
+  (export move->fdes
+	  dup
+	  dup->fdes dup->inport dup->outport
+	  shell-open
+	  open/create+trunc))
 
 (define-interface scsh-process-state-interface
   (export with-resources-aligned
@@ -399,13 +532,13 @@
 	  euid-resource
 	  egid-resource
 
-	  system-name
 	  process-times
 	  cpu-ticks/sec))
 
 
 (define-interface scsh-user/group-db-interface
-  (export user-info
+  (export name->user-info
+	  user-info
 	  user-info:name
 	  user-info:uid
 	  user-info:gid
@@ -415,6 +548,12 @@
 	  ->uid
 	  ->username
 
+	  %homedir		     ; #### for scsh.scm
+
+	  init-home-directory
+	  home-directory
+	  home-dir home-file
+	  
 	  group-info
 	  group-info:name
 	  group-info:gid
@@ -423,15 +562,14 @@
 	  ->gid
 	  ->groupname))
 
-
 (define-interface scsh-command-line-interface
-  (export command-line-arguments
+  (export set-command-line-args!
+	  command-line-arguments
 	  command-line
 	  arg
 	  arg*
 	  argv))
 
-
 (define-interface scsh-signals-interface
   (export signal-process
 	  signal-process-group
@@ -441,12 +579,12 @@
 ))
 
 
-(define-interface scsh-environment-interface
-  (export install-env
-	  setenv
+(define-interface scsh-environments-interface
+  (export setenv
 	  getenv
 	  env->alist
 	  alist->env
+	  alist->env-vec ; #### for %EXEC
 	  alist-delete
 	  alist-update
 	  alist-compress
@@ -458,12 +596,6 @@
 	  add-after
 	  environ-resource))
 
-
-(define-interface scsh-home-interface
-  (export home-directory
-	  exec-path-list))
-
-
 ;;; Kill me?
 (define-interface scsh-regexp-interface
   (export string-match
@@ -480,11 +612,6 @@
 	  regexp-quote))
 
 
-(define-interface scsh-string-interface
-  (export substitute-env-vars
-	  ;string-index string-index-right ; Now in string-lib
-	  ))
-
 (define-interface scsh-file-names-interface
   (export file-name-as-directory
 	  file-name-directory?
@@ -493,20 +620,24 @@
 	  file-name-absolute?
 	  file-name-directory
 	  file-name-nondirectory
+
+	  ensure-file-name-is-nondirectory
+	  ensure-file-name-is-directory
+
 	  split-file-name
 	  path-list->file-name
 	  file-name-extension
 	  file-name-sans-extension
 	  replace-extension
 	  parse-file-name
-	  expand-file-name
-	  simplify-file-name
-	  resolve-tilde-file-name
-	  resolve-file-name
-	  absolute-file-name
-	  home-dir
-	  home-file))
+	  simplify-file-name))
 
+(define scsh-file-names-system-interface
+  (export resolve-tilde-file-name
+	  resolve-file-name
+	  expand-file-name
+	  absolute-file-name
+	  substitute-env-vars))
 
 (define-interface scsh-time-interface
   (export make-date
@@ -582,12 +713,6 @@
 	  (run/sexp       :syntax)
 	  (run/sexps      :syntax)
 
-	  fork/pipe
-	  %fork/pipe
-	  fork/pipe+
-	  %fork/pipe+
-	  tail-pipe
-	  tail-pipe+
 	  run/collecting*
 	  run/port+proc*
 	  run/port*
@@ -595,12 +720,18 @@
 	  run/string*
 	  run/sexp*
 	  run/sexps*
-	  run/strings*
+	  run/strings*))
 
+(define-interface scsh-collect-ports-interface
+  (export port->string
+	  port->list
+	  port->sexp-list
+	  port->string-list
+	  port-fold
+	  reduce-port
 	  make-char-port-filter
 	  make-string-port-filter))
 
-
 (define-interface scsh-version-interface
   (export scsh-major-version
 	  scsh-minor-version
@@ -631,14 +762,27 @@
 	  skip-char-set))
 
 (define-interface scsh-utilities-interface
-  (export mapv mapv! vector-every? copy-vector initialize-vector vector-append
+  (export (define-simple-syntax :syntax)
+	  mapv mapv! vector-every? copy-vector initialize-vector vector-append
 	  vfold vfold-right
 	  check-arg
 	  deprecated-proc
 	  real->exact-integer
 	  make-reinitializer
 	  run-as-long-as
-	  obtain-all-or-none))
+	  obtain-all-or-none with-lock
+	  stringify
+	  bogus-substring-spec?))
+
+(define-interface scsh-resources-interface
+  (export with-resources-aligned
+	  make-resource))
+
+(define-interface scsh-directories-interface
+  (export open-directory-stream
+	  close-directory-stream
+	  read-directory-stream
+	  directory-files))
 
 (define-interface weak-tables-interface
   (export make-weak-table weak-table-set! weak-table-ref weak-table-walk
@@ -1044,6 +1188,19 @@
 	  control-tty-file-name
 	  )))
 
+(define-interface scsh-stdio-interface
+  (export stdports->stdio
+	  stdio->stdports
+	  with-stdio-ports*
+	  (with-stdio-ports :syntax)))
+
+(define-interface scsh-ptys-interface
+  (export fork-pty-session
+	  open-pty
+	  pty-name->tty-name
+	  tty-name->pty-name
+	  make-pty-generator))
+
 (define-interface signal-handler-interface
   (export signal->interrupt
 	  interrupt-set

scsh/scsh-package.scm

@@ -1,9 +1,6 @@
 ;;; The packages that scsh uses/defines.
 ;;; Copyright (c) 1994 by Olin Shivers.
 
-;;; Note: field-reader package (fr.scm) and here docs use READ-LINE.
-;;; It is defined in rdelim.scm.
-
 ;;; You link up a scsh package by defining a package named OS-DEPENDENT
 ;;; that satisfies the interfaces for packages
 ;;;     buffered-io-flags
@@ -22,10 +19,6 @@
 ;;;     -Olin
 
 
-;;; The LET-OPT package for optional argument parsing & defaulting
-;;; is found in the let-opt.scm file.
-
-
 (define-structure error-package (export error warn)
   (open signals)
 ;  (optimize auto-integrate)
@@ -40,6 +33,14 @@
 ;  (optimize auto-integrate)
   )
 
+(define-structure scsh-resources scsh-resources-interface
+  (open scheme
+	define-record-types
+	handle
+	locks
+	scsh-utilities)
+  (files resource))
+
 (define-structure weak-tables weak-tables-interface
   (open scheme
 	weak
@@ -74,7 +75,7 @@
   (open receiving	; receive
 	error-package
 	names	        ; generated? by JMG
-	scsh-utilities	; check-arg
+	(subset scsh-utilities (check-arg))
 	scheme
 	)
   (files syntax-helpers)
@@ -98,6 +99,24 @@
 ;  (optimize auto-integrate)
   )
 
+(define-structure scsh-continuations scsh-continuations-interface
+  (open scheme
+	escapes)
+  (files continuation))
+
+(define-structure scsh-import-os-error-syscalls scsh-import-os-error-syscalls-interface
+  (open scheme
+	handle conditions
+	external-calls
+	(subset os-dependent (errno/intr))
+	(subset scsh-errors (errno-error))
+	scsh-continuations)
+  (files import-os-error-syscall))
+	
+(define-structure scsh-file-syscalls scsh-file-syscalls-interface
+  (open scheme
+	scsh-import-os-error-syscalls)
+  (files file-syscalls))
 
 (define-structure scsh-version scsh-version-interface
   (open scheme)
@@ -115,6 +134,421 @@
 	bitwise)
   (files endian))
 
+(define-structure scsh-environments scsh-environments-interface
+  (open scheme
+	locks thread-fluids
+	(subset primitives (add-finalizer!))
+	defrec-package records
+	(subset signals (error))
+	(subset srfi-1 (fold filter))
+	(subset srfi-13 (string-index string-join))
+	(subset scsh-utilities
+		(with-lock make-reinitializer define-simple-syntax))
+	shared-bindings
+	scsh-import-os-error-syscalls
+	scsh-resources)
+  (files environment))
+
+(define-structure scsh-file-names scsh-file-names-interface
+  (open scheme
+	receiving
+	let-opt
+	signals
+	(subset srfi-1 (reverse!))
+	(subset srfi-13 (string-index string-index-right)))
+  (files fname))
+
+(define-structure scsh-directories scsh-directories-interface
+  (open scheme
+	structure-refs
+	(subset primitives (add-finalizer!))
+	(subset srfi-1 (filter))
+	(subset srfi-13 (string<=))
+	(subset scsh-utilities (check-arg))
+	defrec-package records
+	let-opt
+	(subset scsh-file-syscalls (%open-dir))
+	scsh-import-os-error-syscalls
+	scsh-file-names
+	scsh-resources
+	scsh-process-state)
+  (access sort)
+  (files directory))
+
+(define-structure scsh-user/group-db scsh-user/group-db-interface
+  (open scheme
+	defrec-package
+	receiving
+	handle (subset signals (error))
+	scsh-import-os-error-syscalls
+	scsh-file-names
+	scsh-environments)
+  (files user-group))
+
+(define-structure scsh-process-state scsh-process-state-interface
+  (open scheme
+	receiving
+	let-opt
+	locks thread-fluids
+	(subset channels (set-with-fs-context-aligned*!))
+	(subset signals (error))
+	(subset scsh-utilities (with-lock make-reinitializer define-simple-syntax))
+	scsh-resources
+	scsh-file-names
+	scsh-user/group-db
+	scsh-import-os-error-syscalls)
+  (files process-state))
+
+(define-structure scsh-time scsh-time-interface
+  (open scheme
+	receiving
+	let-opt
+	formats
+	bitwise
+	signals
+	external-calls
+	defrec-package
+	(subset scsh-utilities (check-arg real->exact-integer))
+	scsh-import-os-error-syscalls)
+  (files time
+	 (machine time_dep)))
+
+(define-structure scsh-signal-handlers signal-handler-interface
+  (open scheme
+	external-calls
+	signals
+	enumerated
+	threads
+	interrupts low-interrupt
+	structure-refs
+	(subset scsh-utilities (define-simple-syntax run-as-long-as))
+	(subset os-dependent (signals-ignored-by-default signal/alrm)))
+  (access threads-internal sigevents)
+  (files sighandlers))
+
+(define-structure scsh-newports scsh-newports-interface
+  (open (modify scheme (hide call-with-input-file
+			     call-with-output-file
+			     with-input-from-file
+			     with-output-to-file
+			     open-input-file
+			     open-output-file))
+	structure-refs
+	defrec-package define-record-types
+	bitwise
+	ascii
+	tables weak-tables
+	enumerated
+	byte-vectors
+	fluids
+	placeholders
+	receiving
+	let-opt
+	i/o i/o-internal channels channel-i/o low-channels ports
+	(subset architecture (channel-status-option))
+	(subset primitives (add-pending-channel copy-bytes!))
+	extended-ports
+	scsh-utilities os-dependent buffered-io-flags
+	signals
+	threads
+	(subset srfi-1 (any filter))
+	scsh-file-syscalls
+	scsh-resources
+	scsh-process-state)
+  (access scheme
+	  formats
+	  i/o
+	  threads-internal
+	  interrupts)
+  (files newports))
+
+(define-structure scsh-file scsh-file-interface
+  (open scheme
+	bitwise
+	defrec-package
+	let-opt
+	i/o
+	(subset scsh-utilities (define-simple-syntax deprecated-proc real->exact-integer))
+	os-dependent
+	scsh-errors
+	scsh-file-syscalls
+	scsh-file-names
+	scsh-process-state
+	delimited-readers
+	scsh-newports)
+  (files fileinfo
+	 file
+	 filesys))
+
+(define-structure scsh-temp-files scsh-temp-files-interface
+  (open scheme
+	receiving
+	let-opt
+	bitwise
+	formats
+	os-dependent
+	fluids
+	(subset scsh-utilities (make-reinitializer))
+	scsh-errors
+	scsh-environments
+	scsh-process-state
+	scsh-file
+	scsh-newports)
+  (files temp-file))
+
+(define-structure scsh-globbing scsh-globbing-interface
+  (open scheme
+	ascii
+	receiving
+	(subset srfi-1 (filter fold))
+	srfi-14
+	re-level-0
+	scsh-errors
+	scsh-file-names
+	scsh-file
+	scsh-directories)
+  (files glob))
+
+(define-structure scsh-file-matching scsh-file-matching-interface
+  (open scheme
+	re-level-0
+	signals handle conditions
+	(subset srfi-1 (filter))
+	(subset srfi-13 (string-index-right))
+	scsh-file-names
+	scsh-globbing)
+  (files filemtch))
+
+(define-structure scsh-fcntl scsh-fcntl-interface
+  (open scheme
+	scsh-file-syscalls
+	scsh-newports
+	(subset os-dependent (export fcntl/get-fdes-flags
+				     fcntl/set-fdes-flags
+				     fcntl/get-status-flags
+				     fcntl/set-status-flags)))
+  (files fcntl))
+
+(define-structure scsh-read/write scsh-read/write-interface
+  (open scheme
+	bitwise
+	(subset primitives (copy-bytes!))
+	let-opt
+	signals
+	scsh-newports
+	scsh-fcntl
+	buffered-io-flags
+	(subset scsh-utilities (bogus-substring-spec?))
+	(subset i/o (read-block write-block))
+	(subset i/o-internal (open-input-port?))
+	(subset os-dependent (open/non-blocking)))
+  (files rw))
+
+(define-structure scsh-process-objects scsh-process-objects-interface
+  (open scheme
+	receiving
+	threads
+	locks placeholders
+	signals
+	bitwise
+	tables weak-tables
+	weak
+	let-opt
+	structure-refs
+	defrec-package
+	(subset primitives (add-finalizer!))
+	(subset srfi-1 (delete filter))
+	(subset scsh-utilities (make-reinitializer
+				with-lock run-as-long-as))
+	low-interrupt
+	(subset os-dependent (errno/child))
+	scsh-import-os-error-syscalls
+	scsh-file-names
+	scsh-errors)
+  (access sigevents
+	  threads-internal)
+  (files procobj
+	 (machine waitcodes)))
+
+(define-structure scsh-fdports scsh-fdports-interface
+  (open scheme
+	signals
+	bitwise
+	(subset scsh-utilities (check-arg stringify))
+	os-dependent
+	scsh-file-syscalls
+	scsh-fcntl
+	scsh-newports)
+  (files fdports))
+
+(define-structure scsh-signals scsh-signals-interface
+  (open scheme
+	signals
+	structure-refs
+	scsh-import-os-error-syscalls
+	scsh-process-objects)
+  (access sigevents)
+  (files signal))
+
+(define-structure scsh-processes scsh-processes-interface
+  (open scheme
+	receiving
+	signals
+	i/o
+	let-opt
+	threads thread-fluids
+	structure-refs
+	(subset srfi-13 (string-index))
+	(subset command-levels (session-started? set-batch-mode?!))
+	(subset scsh-utilities (mapv! stringify))
+	scsh-import-os-error-syscalls
+	(subset scsh-environments (alist->env-vec))
+	scsh-continuations
+	scsh-resources
+	scsh-environments
+	scsh-process-state
+	scsh-process-objects
+	scsh-file-names
+	scsh-newports
+	scsh-file
+	scsh-fdports
+	exit-hooks
+	scsh-signals
+	scsh-time
+	(subset os-dependent (signal/stop)))
+  (access interrupts)
+  (files process))
+
+(define-structure scsh-ttys tty-interface
+  (open scheme
+	ascii
+	i/o
+	signals
+	bitwise
+	let-opt
+	defrec-package
+	tty-flags scsh-internal-tty-flags
+	scsh-import-os-error-syscalls
+	scsh-newports
+	(subset os-dependent (open/read+write open/access-mask open/read))
+	scsh-process-objects)
+  (files tty))
+
+(define-structure scsh-stdio scsh-stdio-interface
+  (open scheme
+	(subset i/o (current-error-port))
+	(subset scsh-utilities (define-simple-syntax))
+	scsh-fdports
+	scsh-newports)
+  (files stdio))
+
+(define-structure scsh-ptys scsh-ptys-interface
+  (open scheme
+	receiving
+	scsh-processes
+	scsh-fdports
+	scsh-errors
+	scsh-newports
+	scsh-stdio
+	scsh-ttys
+	scsh-process-state
+	(subset os-dependent (open/read+write)))
+  (files pty))
+
+(define-structure scsh-flock scsh-flock-interface
+  (open scheme
+	signals
+	let-opt
+	threads
+	defrec-package
+	scsh-import-os-error-syscalls
+	os-dependent
+	(subset scsh-utilities (check-arg deprecated-proc))
+	scsh-errors
+	(subset scsh-newports (seek/set))
+	scsh-process-objects)
+  (files flock))
+
+(define-structure scsh-crypt crypt-interface
+  (open scheme
+	signals
+	re-level-0 rx-syntax
+	scsh-import-os-error-syscalls)
+  (files crypt))
+
+(define-structure scsh-system (compound-interface uname-interface
+						  (export system-name) ; ####
+						  )
+  (open scheme
+	defrec-package
+	shared-bindings
+	scsh-import-os-error-syscalls)
+  (files system))
+
+(define-structure scsh-networking (compound-interface sockets-network-interface
+						      scsh-sockets-interface)
+  (open scheme
+	structure-refs
+	receiving
+	let-opt
+	handle signals
+	external-calls shared-bindings
+	defrec-package
+	channel-i/o ports
+	(subset scsh-utilities (bogus-substring-spec?))
+	scsh-import-os-error-syscalls
+	scsh-errors
+	scsh-fdports
+	scsh-newports
+	scsh-fcntl
+	os-dependent)
+  (access interrupts)
+  (files network))
+
+(define-structure scsh-file-names-system scsh-file-names-system-interface
+  (open scheme
+	signals
+	let-opt
+	(subset srfi-1 (reverse!))
+	(subset srfi-13 (string-index))
+	scsh-file-names
+	scsh-environments
+	scsh-user/group-db
+	scsh-process-state)
+  (files fname-system))
+
+(define-structure scsh-collect-ports scsh-collect-ports-interface
+  (open scheme
+	let-opt
+	(subset scsh-utilities (deprecated-proc))
+	(subset srfi-1 (reverse!))
+	scsh-read/write
+	delimited-readers
+	string-collectors)
+  (files port-collect))
+
+(define-structure scsh-high-level-processes scsh-high-level-process-interface
+  (for-syntax (open scsh-syntax-helpers scheme))
+  (open scheme
+	signals
+	receiving
+	let-opt
+	(subset scsh-utilities (define-simple-syntax))
+	(subset srfi-1 (fold))
+	scsh-temp-files
+	scsh-processes scsh-process-objects
+	scsh-stdio
+	scsh-newports
+	scsh-fdports
+	scsh-collect-ports)
+  (files syntax
+	 process-high-level))
+
+(define-structure scsh-command-line scsh-command-line-interface
+  (open scheme
+	signals)
+  (files command-line))
+
 ;;; The scsh-level-0 package is for implementation convenience.
 ;;; The scsh startup and top-level modules need access to scsh
 ;;; procedures, but they export procedures that are themselves
@@ -133,14 +567,19 @@
 			scsh-errors-interface
 			scsh-io-interface
 			scsh-file-interface
-			scsh-process-interface
+			scsh-fcntl-interface
+			scsh-read/write-interface
+			scsh-globbing-interface
+			scsh-file-matching-interface
+			scsh-temp-files-interface
+			scsh-directories-interface
 			scsh-process-state-interface
+			scsh-process-objects-interface
+			scsh-processes-interface
 			scsh-user/group-db-interface
 			scsh-command-line-interface
 			scsh-signals-interface
-			scsh-environment-interface
-			scsh-home-interface
-			scsh-string-interface
+			scsh-environments-interface
 			scsh-file-names-interface
 			scsh-misc-interface
 			scsh-high-level-process-interface
@@ -151,6 +590,8 @@
 			scsh-version-interface
 			(interface-of srfi-14) ;; export this here for
 			(export ->char-set)    ;; this kludge
+			(export system-name) ; #### has nowhere else to go for now
+			scsh-file-names-system-interface
 			signal-handler-interface
 			;; This stuff would probably be better off kept
 			;; in separate modules, but we'll toss it in for now.
@@ -161,20 +602,16 @@
 			uname-interface
 			))
    (scsh-level-0-internals (export set-command-line-args!
-				   init-scsh-hindbrain
-				   initialize-cwd
-				   init-scsh-vars))
+				   init-home-directory
+				   init-exec-path-list))
 ;   (scsh-regexp-package scsh-regexp-interface)
 )
   (for-syntax (open scsh-syntax-helpers scheme))
   (access rts-sigevents sigevents threads)
   (open enumerated
 	defenum-package
-	external-calls           ;JMG new FFI
-	structure-refs
 	receiving
 	defrec-package
-	define-record-types
 	formats
 	string-collectors
 	delimited-readers
@@ -188,93 +625,60 @@
 	bigbit
 	bitwise
 	signals
-	conditions
-	(subset srfi-1 (filter reverse! fold delete any))
-	scsh-utilities
-	handle
-	fluids thread-fluids
-	weak-tables
 
 	srfi-14
-;	scsh-regexp-package
-;	scsh-regexp-internals
+
 	scsh-version
 	tty-flags
-	scsh-internal-tty-flags	; Not exported
 
-	syslog
-
-	let-opt			; optional-arg parsing & defaulting
+	scsh-continuations
+	scsh-import-os-error-syscalls
+	scsh-file-syscalls
+	scsh-resources
+	scsh-environments
+	scsh-file-names
+	scsh-directories
+	scsh-user/group-db
+	scsh-process-state
+	scsh-time
+	scsh-signal-handlers
+	scsh-newports
+	scsh-file
+	scsh-read/write
+	scsh-fcntl
+	scsh-temp-files
+	scsh-globbing
+	scsh-file-matching
+	scsh-process-objects
+	scsh-processes
+	scsh-fdports
+	scsh-signals
+	scsh-ttys
+	scsh-stdio
+	scsh-ptys
+	scsh-flock
+	scsh-crypt
+	scsh-system
+	scsh-networking
+	scsh-file-names-system
+	scsh-high-level-processes
+	scsh-collect-ports
+	scsh-command-line
 	
-	architecture     ; Was this by JMG ??
+	syslog
 
 	re-level-0
 	rx-syntax
 
 	srfi-13
 
-	thread-fluids			; For exec-path-list
-	loopholes		; For my bogus CALL-TERMINALLY implementation.
-
-	(modify scheme (hide call-with-input-file
-			     call-with-output-file
-			     with-input-from-file
-			     with-output-to-file
-			     open-input-file
-			     open-output-file))
+	(subset scheme (define
+			 input-port? output-port?))
 			     
-	low-interrupt            ; for sighandler and procobj
-	;; all these seem to be for scsh-0.6 JMG
-	i/o
-	i/o-internal
-	channels channel-i/o
-	low-channels
-	byte-vectors
-	threads locks placeholders
-	primitives
-	escapes
-	command-levels
-	features
-	general-tables
-	simple-syntax
-	exit-hooks
+	(subset i/o (current-error-port))
 
 	scsh-errors
-	scsh-endian)  
-  (for-syntax (open scsh-syntax-helpers scheme))
-  (access interrupts
-	  sort
-	  command-processor
-	  escapes
-	  i/o		; S48's force-output
-	  exceptions    ; signal-exception
-	  formats
-	  threads-internal 
-	  records	; I don't think this is necessary. !!!
-	  scheme)	; For accessing the normal I/O operators.
-  (files syntax
-	 syscalls
-	 fname
-	 rw
-	 newports
-	 fdports
-	 procobj		; New in release 0.4.
-	 (machine waitcodes)	; OS dependent code.
-	 filesys
-	 fileinfo
-	 glob
-	 filemtch
-	 time			; New in release 0.2.
-	 (machine time_dep)
-	 network		; New in release 0.3.
-	 flock			; New in release 0.4.
-	 tty			; New in release 0.4.
-	 pty			; New in release 0.4.
-	 sighandlers		; New in release 0.5.
-	 scsh
-;	 re
-	 )
-;  (optimize auto-integrate)
+	scsh-endian)
   (begin
     ;; work around for SRFI 14 naming fuckage
     (define ->char-set x->char-set))
@@ -305,7 +709,9 @@
 					       make-scsh-starter
 					       scsh-stand-alone-resumer)
   (open scsh-level-0-internals	; init-scsh-* set-command-line-args!
-	scsh-level-0		; error-output-port command-line-arguments
+	(subset scsh-level-0 (init-fdports!
+			      error-output-port current-error-port
+			      command-line command-line-arguments))
 	scsh-top-package	; parse-switches-and-execute
 	handle			; with-handler
 	command-levels  	; user-context
@@ -358,9 +764,34 @@
 	packages
 	receiving
 	scsh-version
-	scsh-level-0		; with-current-input-port error-output-port
-				; with-current-output-port exit
-	scsh-level-0-internals	; set-command-line-args! init-scsh-vars
+	(subset scsh-level-0 (error-output-port
+			      with-current-input-port with-current-output-port
+			      exit
+			      fdes->inport
+			      release-port-handle
+			      getenv
+			      user-uid
+			      user-info
+			      user-info:home-dir
+			      init-home-directory
+			      init-exec-path-list
+			      with-autoreaping
+			      with-scsh-sighandlers
+			      command-line
+			      flush-all-ports-no-threads
+			      file-name-absolute?
+			      file-name-directory
+			      file-name-directory?
+			      absolute-file-name
+			      directory-files
+			      file-directory?
+			      resolve-file-name
+			      substitute-env-vars
+			      skip-char-set
+			      char->ascii
+			      ascii->char))
+
+	(subset scsh-level-0-internals (set-command-line-args! init-scsh-vars))
 	threads
 	(subset srfi-1 (any))
 	(subset srfi-14 (char-set

scsh/signal.scm

@@ -0,0 +1,54 @@
+;;; Signals (rather incomplete)
+;;; ---------------------------
+
+(import-os-error-syscall signal-pid (pid signal) "scsh_kill")
+
+(define (signal-process proc signal)
+  (signal-pid (cond ((proc? proc)    (proc:pid proc))
+		    ((integer? proc) proc)
+		    (else (error "Illegal proc passed to signal-process" proc)))
+	      signal))
+
+(define (signal-process-group proc-group signal)
+  (signal-pid (- (cond ((proc? proc-group)    (proc:pid proc-group))
+		       ((integer? proc-group) proc-group)
+		       (else (error "Illegal proc passed to signal-process-group"
+                                    proc-group))))
+              signal))
+(define (itimer sec)
+  ((structure-ref sigevents schedule-timer-interrupt!) (* sec 1000)))
+;;; SunOS, not POSIX:
+;;; (define-foreign signal-process-group/errno
+;;;   (killpg (integer proc-group) (integer signal))
+;;;   (to-scheme integer errno_or_false))
+;;; 
+;;; (define-errno-syscall (signal-process-group proc-group signal)
+;;;   signal-process-group/errno)
+
+
+
+
+;;; I do this one in C, I'm not sure why:
+;;; It is used by MATCH-FILES.
+;;; 99/7: No one is using this function, so I'm commenting it out.
+;;; Later, we could tune up the globber or regexp file-matcher to use
+;;; it (but should shift it into the rx directory). But I should also go
+;;; to a file-at-a-time cursor model for directory fetching. -Olin
+
+;(define-foreign %filter-C-strings!
+;  (filter_stringvec (string pattern) ((C "char const ** ~a") cvec))
+;  static-string	; error message -- #f if no error.
+;  integer)	; number of files that pass the filter.
+
+
+;(define (match-files regexp . maybe-dir)
+;  (let ((dir (:optional maybe-dir ".")))
+;    (check-arg string? dir match-files)
+;    (receive (err cvec numfiles)
+;	     (%open-dir (ensure-file-name-is-nondirectory dir))
+;      (if err (errno-error err match-files regexp dir))
+;      (receive (err numfiles) (%filter-C-strings! regexp cvec)
+;	(if err (error err match-files))
+;	(%sort-file-vector cvec numfiles)
+;	(let ((files (C-string-vec->Scheme&free cvec numfiles)))
+;	  (vector->list files))))))

scsh/stdio.scm

@@ -0,0 +1,22 @@
+;;; Stdio/stdport sync procedures
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (stdio->stdports)
+  (set-current-input-port!  (fdes->inport 0))
+  (set-current-output-port! (fdes->outport 1))
+  (set-current-error-port!   (fdes->outport 2)))
+
+(define (with-stdio-ports* thunk)
+  (with-current-input-port (fdes->inport 0)
+    (with-current-output-port (fdes->outport 1)
+      (with-current-error-port (fdes->outport 2)
+	(thunk)))))
+
+(define-simple-syntax (with-stdio-ports body ...)
+  (with-stdio-ports* (lambda () body ...)))
+
+
+(define (stdports->stdio)
+  (dup (current-input-port)  0)
+  (dup (current-output-port) 1)
+  (dup (current-error-port)   2))

scsh/syntax.scm

@@ -2,11 +2,6 @@
 ;;; Translating process forms into Scheme code.
 ;;; 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))))))
-
 ;;; The three basic forms for running an extended process form:
 ;;; EXEC-EPF, &, and RUN. EXEC-EPF is the foundation.
 
@@ -73,3 +68,18 @@
 ;(define-simple-syntax (test-mac trans . form)
 ;  (pp (expand-mac trans (quote form))))
 
+
+;; Return a Unix port such that reads on it get the chars produced by
+;; DISPLAYing OBJ. For example, if OBJ is a string, then reading from
+;; the port produces the characters of OBJ.
+;; 
+;; This implementation works by writing the string out to a temp file,
+;; but that isn't necessary. It could work, for example, by forking off a 
+;; writer process that outputs to a pipe, i.e.,
+;;     (run/port (begin (display obj (fdes->outport 1))))
+
+(define (open-string-source obj)
+  (receive (inp outp) (temp-file-channel)
+    (display obj outp)
+    (close-output-port outp)
+    inp))

scsh/syscalls.scm

@@ -1,761 +0,0 @@
-;;; POSIX system-call Scheme binding.
-;;; Copyright (c) 1993 by Olin Shivers.
-
-;;; Scheme48 implementation.
-
-;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Import a C function and convert the exception os-error to a syscall-error
-;;;
-;;; 1.) Import a C function
-;;; 2.) Turn os-error into syscall-error
-;;; 3.) Retry on EINTR
-;;; The call/cc and the record is due to S48's broken exception system:
-;;; You can't throw an error within a handler
-;;;
-
-;;; Move this to somewhere else as soon as Marc has published his SRFI
-(define (continuation-capture receiver)
-  ((call-with-current-continuation
-    (lambda (cont)
-      (lambda () (receiver cont))))))
-
-(define (continuation-graft cont thunk)
-  (cont thunk))
-
-(define (continuation-return cont . returned-values)
-  (continuation-graft
-   cont
-   (lambda () (apply values returned-values))))
-
-(define-syntax import-os-error-syscall
-  (syntax-rules ()
-    ((import-os-error-syscall syscall (%arg ...) c-name)
-     (begin 
-       (import-lambda-definition syscall/eintr (%arg ...) c-name)
-       (define (syscall %arg ...)
-	 (let ((arg %arg) ...)
-	   (continuation-capture 
-	    (lambda (cont)
-	      (let loop ()
-		(with-handler
-		 (lambda (condition more)
-		   (if (and (exception? condition) (eq? (exception-reason condition) 
-							'os-error))
-		       (let ((stuff (exception-arguments condition)))
-			 (if (= (cadr stuff) errno/intr)
-			     (loop)
-			     (continuation-graft
-			      cont
-			      (lambda ()
-				(apply errno-error 
-				       (cadr stuff)   ; errno
-				       (caddr stuff)  ;msg
-				       syscall 
-				       (cdddr stuff)))))) ;packet
-		       (more)))
-		 (lambda ()
-		   (syscall/eintr %arg ...))))))))))))
-  
-;;; Process
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; we can't algin env here, because exec-path/env calls
-;; %%exec/errno directly  F*&% *P
-(import-os-error-syscall %%exec (prog argv env) "scheme_exec")
-
-(define (%exec prog arg-list env)
-  (let ((argv (mapv! stringify (list->vector arg-list)))
-	(prog (stringify prog))
-	(env (if (eq? env #t) #t (alist->env-vec env))))
-    (%%exec prog argv env)))
-
-
-(import-os-error-syscall exit/errno ; errno -- misnomer.
-  (status) "scsh_exit")
-
-(import-os-error-syscall %exit/errno ; errno -- misnomer
-  (status) "scsh__exit")
-
-(define (%exit . maybe-status)
-  (%exit/errno (:optional maybe-status 0))
-  (error "Yikes! %exit returned."))
-
-
-(import-os-error-syscall %%fork () "scsh_fork")
-
-;;; Posix waitpid(2) call.
-(import-os-error-syscall %wait-pid/list (pid options) "wait_pid")
-
-(define (%wait-pid pid options)
-  (apply values (%wait-pid/list pid options)))
-
-;;; Miscellaneous process state
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Working directory
-
-(import-os-error-syscall %chdir (directory) "scsh_chdir")
-
-;;; These calls change/reveal the process working directory
-;;; 
-
-(define (process-chdir . maybe-dir)
-  (let ((dir (:optional maybe-dir (home-dir))))
-    (%chdir (ensure-file-name-is-nondirectory dir))))
-
-;; TODO: we get an error if cwd does not exist on startup
-(import-os-error-syscall process-cwd () "scheme_cwd")
-
-;;; GID
-
-(import-os-error-syscall user-gid  () "scsh_getgid")
-
-(import-os-error-syscall process-user-effective-gid () "scsh_getegid")
-
-(import-os-error-syscall process-set-gid (gid) "scsh_setgid")
-
-(import-os-error-syscall set-process-user-effective-gid (gid) "scsh_setegid")
-
-(import-os-error-syscall user-supplementary-gids () "get_groups")
-
-;;; UID
-(import-os-error-syscall user-uid  () "scsh_getuid")
-
-(import-os-error-syscall process-user-effective-uid () "scsh_geteuid")
-
-(import-os-error-syscall process-set-uid (uid) "scsh_setuid")
-
-(import-os-error-syscall set-process-user-effective-uid (uid) "scsh_seteuid")
-
-(import-os-error-syscall %user-login-name () "my_username")
- 
-(define (user-login-name)
-  (or (%user-login-name)
-      (error "Cannot get your name")))
-
-;;; PID
-
-(import-os-error-syscall pid () "scsh_getpid")
-(import-os-error-syscall parent-pid () "scsh_getppid")
-;;; Process groups and session ids
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(import-os-error-syscall process-group () "scsh_getpgrp")
-
-(import-os-error-syscall %set-process-group (pid groupid) "scsh_setpgid")
-
-(define (set-process-group arg1 . maybe-arg2)
-  (receive (pid pgrp) (if (null? maybe-arg2)
-			  (values (pid) arg1)
-			  (values arg1 (car maybe-arg2)))
-	   (%set-process-group pid pgrp)))
-
-
-(import-os-error-syscall become-session-leader () "scsh_setsid")
-
-;;; UMASK
-
-(import-os-error-syscall set-process-umask (mask) "scsh_umask")
-
-(define (process-umask)
-  (let ((m (set-process-umask 0)))
-    (set-process-umask m)
-    m))
-
-
-;;; PROCESS TIMES
-
-;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
-
-
-(import-os-error-syscall process-times/list () "process_times")
-
-(define (process-times)
-  (apply values (process-times/list)))
-
-(import-os-error-syscall cpu-ticks/sec () "cpu_clock_ticks_per_sec")
-
-;;; File system
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Useful little utility for generic ops that work on filenames, fd's or
-;;; ports.
-
-(define (generic-file-op thing fd-op fname-op)
-  (if (string? thing) 
-      (with-resources-aligned (list cwd-resource euid-resource egid-resource) 
-			      (lambda () (fname-op thing)))
-      (call/fdes thing fd-op)))
-
-
-(import-os-error-syscall %set-file-mode (path mode) "scsh_chmod")
-
-(import-os-error-syscall %set-fdes-mode (path mode) "scsh_fchmod")
-
-(define (set-file-mode thing mode)
-  (generic-file-op thing
-		   (lambda (fd)    (%set-fdes-mode fd    mode))
-		   (lambda (fname) (%set-file-mode fname mode))))
-
-
-(import-os-error-syscall set-file-uid&gid (path uid gid) "scsh_chown")
-
-(import-os-error-syscall set-fdes-uid&gid (fd uid gid) "scsh_fchown")
-
-(define (set-file-owner thing uid)
-  (generic-file-op thing
-		   (lambda (fd)    (set-fdes-uid&gid fd    uid -1))
-		   (lambda (fname) (set-file-uid&gid fname uid -1))))
-
-(define (set-file-group thing gid)
-  (generic-file-op thing
-		   (lambda (fd)    (set-fdes-uid&gid fd    -1 gid))
-		   (lambda (fname) (set-file-uid&gid fname -1 gid))))
-
-
-;;; Uses real uid and gid, not effective. I don't use this anywhere.
-
-(import-os-error-syscall %file-ruid-access-not? (path perms) "scsh_access")
-
-;(define (file-access? path perms)
-;  (not (%file-access-not? path perms)))
-;
-;(define (file-executable? fname)
-;  (file-access? fname 1))
-;
-;(define (file-writable? fname)
-;  (file-access? fname 2))
-;
-;(define (file-readable? fname)
-;  (file-access? fname 4))
-
-
-(import-os-error-syscall %create-hard-link (original-name new-name) 
-  "scsh_link")
-
-(import-os-error-syscall %create-fifo (path mode) "scsh_mkfifo")
-
-(import-os-error-syscall %%create-directory (path mode) "scsh_mkdir")
-
-(define (%create-directory path . maybe-mode)
-  (let ((mode (:optional maybe-mode #o777))
-	(fname (ensure-file-name-is-nondirectory path)))
-    (%%create-directory fname mode)))
-
-(import-os-error-syscall %read-symlink (path) "scsh_readlink")
-
-(import-os-error-syscall %rename-file (old-name new-name) "scsh_rename")
-
-(import-os-error-syscall %delete-directory (path) "scsh_rmdir")
-
-(import-os-error-syscall %utime (path ac m) "scm_utime") 
-
-(import-os-error-syscall %utime-now (path) "scm_utime_now")
-
-;;; (SET-FILE-TIMES path [access-time mod-time])
-
-(define (set-file-times path . maybe-times)
-  (with-resources-aligned 
-   (list cwd-resource euid-resource egid-resource) 
-   (lambda ()      
-     (if (pair? maybe-times)
-	 (let* ((access-time (real->exact-integer (car maybe-times)))
-		(mod-time (if (pair? (cddr maybe-times))
-			      (error "Too many arguments to set-file-times/errno"
-				     (cons path maybe-times))
-			      (real->exact-integer (cadr maybe-times)))))
-	   (%utime path access-time 
-		   mod-time ))
-	 (%utime-now path)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; STAT
-
-(import-os-error-syscall stat-file (path data chase?) "scheme_stat")
-
-(import-os-error-syscall stat-fdes (fd data) "scheme_fstat")
-
-(define-record file-info
-  type
-  device
-  inode
-  mode
-  nlinks
-  uid
-  gid
-  size
-  atime
-  mtime
-  ctime
-  )
-
-
-;;; Should be redone to return multiple-values.
-(define (%file-info fd/port/fname chase?)
-  (let ((ans-vec (make-vector 11))
-	(file-type (lambda (type-code)
-		     (vector-ref '#(block-special char-special directory fifo
-						  regular socket symlink)
-				 type-code))))
-    (generic-file-op fd/port/fname
-		     (lambda (fd)
-		       (stat-fdes fd ans-vec))
-		     (lambda (fname)
-		       (stat-file fname ans-vec chase?)))
-    (make-file-info (file-type (vector-ref ans-vec 0))
-		    (vector-ref ans-vec 1)
-		    (vector-ref ans-vec 2)
-		    (vector-ref ans-vec 3)
-		    (vector-ref ans-vec 4)
-		    (vector-ref ans-vec 5)
-		    (vector-ref ans-vec 6)
-		    (vector-ref ans-vec 7)
-		    (vector-ref ans-vec 8)
-		    (vector-ref ans-vec 9)
-		    (vector-ref ans-vec 10))))
-						      
-		
-(define (file-info fd/port/fname . maybe-chase?)
-  (let ((chase? (:optional maybe-chase? #t)))
-    (%file-info fd/port/fname chase?)))
-
-
-(define file-attributes
-  (deprecated-proc file-info "file-attributes" "Use file-info instead."))
-
-
-;;; "no-declare" as there is no agreement among the OS's as to whether or not
-;;; the OLD-NAME arg is "const". It *should* be const.
-
-(import-os-error-syscall %create-symlink (old-name new-name) "scsh_symlink")
-  
-;;; "no-declare" as there is no agreement among the OS's as to whether or not
-;;; the PATH arg is "const". It *should* be const.
-
-(import-os-error-syscall %truncate-file (path length) "scsh_truncate")
-
-(import-os-error-syscall %truncate-fdes (path length) "scsh_ftruncate")
-
-(define (truncate-file thing length)
-  (generic-file-op thing
-		   (lambda (fd)    (%truncate-fdes fd    length))
-		   (lambda (fname) (%truncate-file fname length))))
-
-(import-os-error-syscall %delete-file (path) "scsh_unlink")
-
-(define (delete-file path)
-  (with-resources-aligned (list cwd-resource euid-resource egid-resource) 
-			  (lambda () (%delete-file path))))
-
-(import-os-error-syscall %sync-file (fd) "scsh_fsync")
-
-(define (sync-file fd/port)
-  (if (output-port? fd/port) (force-output fd/port))
-  (sleazy-call/fdes fd/port %sync-file))
-
-
-;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
-(import-os-error-syscall sync-file-system () "scsh_sync")
-
-;;; I/O
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(import-os-error-syscall %close-fdes (fd) "scsh_close")
-
-(import-os-error-syscall %dup (fd) "scsh_dup")
-
-(import-os-error-syscall %dup2 (fd-from fd-to) "scsh_dup2")
-
-(import-os-error-syscall %fd-seek (fd offset whence) "scsh_lseek")
-
-
-(define seek/set 0)			;Unix codes for "whence"
-(define seek/delta 1)
-(define seek/end 2)
-
-(define (seek fd/port offset . maybe-whence)
-  (let ((whence (:optional maybe-whence seek/set))
-	(fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
-    (%fd-seek fd offset whence)))
-
-(define (tell fd/port)
-  (let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
-    (%fd-seek fd 0 seek/delta)))
-
-(import-os-error-syscall %char-ready-fdes? (fd) "char_ready_fdes")
-
-(import-os-error-syscall %open (path flags mode) "scsh_open")
-
-(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
-    (with-resources-aligned 
-     (list cwd-resource umask-resource euid-resource egid-resource)
-     (lambda ()
-      (%open path flags (:optional maybe-mode #o666)))))
-
-
-(import-os-error-syscall pipe-fdes () "scheme_pipe")
-
-(define (pipe)
-  (apply (lambda (r-fd w-fd)
-	   (let ((r (fdes->inport  r-fd))
-		 (w (fdes->outport w-fd)))
-	     (release-port-handle r)
-	     (release-port-handle w)
-	     (values r w)))
-	 (pipe-fdes)))
-
-;;; Signals (rather incomplete)
-;;; ---------------------------
-
-(import-os-error-syscall signal-pid (pid signal) "scsh_kill")
-
-(define (signal-process proc signal)
-  (signal-pid (cond ((proc? proc)    (proc:pid proc))
-		    ((integer? proc) proc)
-		    (else (error "Illegal proc passed to signal-process" proc)))
-	      signal))
-
-(define (signal-process-group proc-group signal)
-  (signal-pid (- (cond ((proc? proc-group)    (proc:pid proc-group))
-		       ((integer? proc-group) proc-group)
-		       (else (error "Illegal proc passed to signal-process-group"
-                                    proc-group))))
-              signal))
-(define (itimer sec)
-  ((structure-ref sigevents schedule-timer-interrupt!) (* sec 1000)))
-;;; SunOS, not POSIX:
-;;; (define-foreign signal-process-group/errno
-;;;   (killpg (integer proc-group) (integer signal))
-;;;   (to-scheme integer errno_or_false))
-;;; 
-;;; (define-errno-syscall (signal-process-group proc-group signal)
-;;;   signal-process-group/errno)
-
-
-;;; User info
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-record user-info
-  name uid gid home-dir shell
-
-  ;; Make user-info records print like #{user-info shivers}.
-  ((disclose ui)
-   (list "user-info" (user-info:name ui))))
-
-
-(import-os-error-syscall
- %uid->user-info 
- (uid user-info-record)
- "user_info_uid")
-
-(import-os-error-syscall
- %name->user-info 
- (name user-info-record)
- "user_info_name")
-
-(define (uid->user-info uid)
-  (let ((empty-user-info (make-user-info #f uid #f #f #f)))
-    (if (%uid->user-info uid empty-user-info)
-	empty-user-info
-	(error "Cannot get user's information" uid->user-info uid)))) 
-
-
-(define (name->user-info name)
-  (let ((empty-user-info (make-user-info name #f #f #f #f)))
-    (if (%name->user-info name empty-user-info)
-	empty-user-info
-	(error "Cannot get user's information" name->user-info name))))
-
-(define (user-info uid/name)
-  ((cond ((string?  uid/name) name->user-info)
-	 ((integer? uid/name) uid->user-info)
-	 (else (error "user-info arg must be string or integer" uid/name)))
-   uid/name))
-
-;;; Derived functions
-
-(define (->uid uid/name)
-  (user-info:uid (user-info uid/name)))
-
-(define (->username uid/name)
-  (user-info:name (user-info uid/name)))
-
-(define (%homedir uid/name)
-  (user-info:home-dir (user-info uid/name)))
-
-
-;;; Group info
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-record group-info
-  name gid members
-
-  ;; Make group-info records print like #{group-info wheel}.
-  ((disclose gi) (list "group-info" (group-info:name gi))))
-
-(import-os-error-syscall
- %gid->group-info 
- (gid group-info-record)
- "group_info_gid")
-
-(import-os-error-syscall
- %name->group-info 
- (name group-info-record)
- "group_info_name")
-
-(define (gid->group-info  gid)
-  (let ((empty-group-info (make-group-info #f gid #f)))
-    (if (%gid->group-info gid empty-group-info)
-	empty-group-info
-	(error "Cannot get group's information for gid" gid))))
-							
-(define (name->group-info name)
-  (let ((empty-group-info (make-group-info name #f #f)))
-    (if (%name->group-info name empty-group-info)
-	empty-group-info
-	(error "Cannot get group's information for name" name))))
-
-(define (group-info gid/name)
-  ((cond ((string?  gid/name) name->group-info)
-	 ((integer? gid/name) gid->group-info)
-	 (else (error "group-info arg must be string or integer" gid/name)))
-   gid/name))
-
-;;; Derived functions
-
-(define (->gid name)
-  (group-info:gid (group-info name)))
-
-(define (->groupname gid)
-  (group-info:name (group-info gid)))
-
-;;; Directory stuff
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(import-os-error-syscall %open-dir (dir-name) "directory_files")
-
-(define (directory-files . args)
-  (with-resources-aligned
-   (list cwd-resource euid-resource egid-resource)
-   (lambda ()
-     (let-optionals args ((dir       ".")
-			  (dotfiles? #f))
-       (check-arg string? dir directory-files)
-       (let* ((files (%open-dir (ensure-file-name-is-nondirectory dir)))
-	      (files-sorted ((structure-ref sort sort-list!) files filename<=)))
-	 (if dotfiles? files-sorted
-	     (filter (lambda (f) (not (dotfile? f)))
-		     files-sorted)))))))
-
-(define (dotfile? f)
-  (char=? (string-ref f 0) #\.))
-
-(define (filename<= f1 f2)
-  (if (dotfile? f1)
-      (if (dotfile? f2)
-	  (string<= f1 f2)
-	  #t)
-      (if (dotfile? f2)
-	  #f
-	  (string<= f1 f2))))
-
-; A record for directory streams.  It just has the name and a byte vector
-; containing the C directory object.  The name is used only for printing.
-
-(define-record directory-stream
-  name
-  c-dir)
-
-(define-record-discloser type/directory-stream
-  (lambda (ds)
-    (list 'directory-stream (directory-stream:name ds))))
-
-; Directory streams are meaningless in a resumed image.
-(define-record-resumer type/directory-stream #f)
-
-(define (open-directory-stream name)
-  (let ((dir (make-directory-stream 
-	      name
-	      (with-resources-aligned 
-	       (list cwd-resource euid-resource egid-resource)
-	       (lambda ()
-		 (open-dir name))))))
-    (add-finalizer! dir close-directory-stream)
-    dir))
-
-(define (read-directory-stream dir-stream)
-  (read-dir (directory-stream:c-dir dir-stream)))
-
-(define (close-directory-stream dir-stream)
-  (let ((c-dir (directory-stream:c-dir dir-stream)))
-    (if c-dir
-	(begin
-	  (close-dir c-dir)
-	  (set-directory-stream:c-dir dir-stream #f)))))
-
-(import-os-error-syscall open-dir (name) "scm_opendir")
-(import-os-error-syscall close-dir (dir-stream) "scm_closedir")
-(import-os-error-syscall read-dir (dir-stream) "scm_readdir")
-
-
-;;; I do this one in C, I'm not sure why:
-;;; It is used by MATCH-FILES.
-;;; 99/7: No one is using this function, so I'm commenting it out.
-;;; Later, we could tune up the globber or regexp file-matcher to use
-;;; it (but should shift it into the rx directory). But I should also go
-;;; to a file-at-a-time cursor model for directory fetching. -Olin
-
-;(define-foreign %filter-C-strings!
-;  (filter_stringvec (string pattern) ((C "char const ** ~a") cvec))
-;  static-string	; error message -- #f if no error.
-;  integer)	; number of files that pass the filter.
-
-
-;(define (match-files regexp . maybe-dir)
-;  (let ((dir (:optional maybe-dir ".")))
-;    (check-arg string? dir match-files)
-;    (receive (err cvec numfiles)
-;	     (%open-dir (ensure-file-name-is-nondirectory dir))
-;      (if err (errno-error err match-files regexp dir))
-;      (receive (err numfiles) (%filter-C-strings! regexp cvec)
-;	(if err (error err match-files))
-;	(%sort-file-vector cvec numfiles)
-;	(let ((files (C-string-vec->Scheme&free cvec numfiles)))
-;	  (vector->list files))))))
-
-
-;;; Environment manipulation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; (var . val) / "var=val" rep conversion:
-
- 
-
-(define (split-env-string var=val)
-  (let ((i (string-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-vec alist)
-  (list->vector (map (lambda (var.val)
-		       (string-append (car var.val) "="
-				      (let ((val (cdr var.val)))
-					(if (string? val) val
-					    (string-join val ":")))))
-		     alist)))
-
-;;; ENV->ALIST
-
-(import-os-error-syscall %load-env () "scm_envvec")
-
-(define (environ-env->alist) 
-  (let ((env-list.envvec (%load-env)))
-    (cons (env-list->alist (car env-list.envvec)) 
-	  (cdr env-list.envvec))))
-
-	   
-;;; ALIST->ENV
-
-;;; (%create-env ((vector 'X) -> address))
-(import-os-error-syscall %create-env (envvec) "create_env")
-
-;;; assumes aligned env
-(define (envvec-alist->env alist)
-  (%create-env (alist->env-vec alist)))
-
-(import-os-error-syscall %align-env (envvec) "align_env")
-
-(import-os-error-syscall %free-env (envvec) "free_envvec")
-
-
-;;; Fd-ports
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(import-os-error-syscall %set-cloexec (fd val) "set_cloexec")
-
-;;; Some of fcntl()
-;;;;;;;;;;;;;;;;;;;
-
-(import-os-error-syscall %fcntl-read (fd command) "fcntl_read")
-(import-os-error-syscall %fcntl-write (fd command val) "fcntl_write")
-
-;;; fcntl()'s F_GETFD and F_SETFD.  Note that the SLEAZY- prefix on the
-;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour
-;;; of these procedures. Straight CALL/FDES modifies unrevealed file
-;;; descriptors by clearing their CLOEXEC bit when it reveals them -- so it
-;;; would interfere with the reading and writing of that bit!
-
-(define (fdes-flags fd/port)
-  (sleazy-call/fdes fd/port
-    (lambda (fd) (%fcntl-read fd fcntl/get-fdes-flags))))
-
-(define (set-fdes-flags fd/port flags)
-  (sleazy-call/fdes fd/port
-    (lambda (fd) (%fcntl-write fd fcntl/set-fdes-flags flags))))
-
-;;; fcntl()'s F_GETFL and F_SETFL.
-;;; Get: Returns open flags + get-status flags (below)
-;;; Set: append, sync, async, nbio, nonblocking, no-delay
-
-(define (fdes-status fd/port)
-  (sleazy-call/fdes fd/port
-    (lambda (fd) (%fcntl-read fd fcntl/get-status-flags))))
-
-(define (set-fdes-status fd/port flags)
-  (sleazy-call/fdes fd/port
-    (lambda (fd) (%fcntl-write fd fcntl/set-status-flags flags))))
-
-;;; Miscellaneous
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; usleep(3): Try to sleep for USECS microseconds.
-;;; sleep(3):  Try to sleep for SECS seconds.
-
-; De-released -- not POSIX and not on SGI systems.
-; (define-foreign usleep (usleep (integer usecs)) integer)
-
-(define (process-sleep secs) (process-sleep-until (+ secs (time))))
-
-(define (process-sleep-until when)
-  (let* ((when (floor when))	; Painful to do real->int in Scheme.
-	 (when (if (exact? when) when (inexact->exact when))))
-    (let lp ()
-      (or (%sleep-until when) (lp)))))
-
-(import-os-error-syscall %sleep-until (secs) "sleep_until")
-
-(import-os-error-syscall %gethostname () "scm_gethostname")
-
-(define system-name %gethostname)
-
-(import-os-error-syscall errno-msg (i) "errno_msg")
-
-(import-os-error-syscall %crypt (key salt) "scm_crypt")
-
-(define (crypt key salt)
-  (let* ((allowed-char-set  (rx (| alpha digit "." "/")))
-	 (salt-regexp  (rx (: ,allowed-char-set ,allowed-char-set))))
-    (if (not (= (string-length salt) 2)) (error "salt must have length 2"))
-    (if (not (regexp-search? salt-regexp salt))
-	(error "illegal char in salt " salt))
-    (if (> (string-length key) 8) (error "key too long "  (string-length key)))
-    (%crypt key salt)))
-
-(define-record uname
-  os-name
-  node-name
-  release
-  version
-  machine)
-
-(define-exported-binding "uname-record-type" type/uname)
-
-(import-os-error-syscall uname () "scm_uname")

scsh/system.scm

@@ -0,0 +1,14 @@
+(import-os-error-syscall %gethostname () "scm_gethostname")
+
+(define system-name %gethostname)
+
+(define-record uname
+  os-name
+  node-name
+  release
+  version
+  machine)
+
+(define-exported-binding "uname-record-type" type/uname)
+
+(import-os-error-syscall uname () "scm_uname")

scsh/temp-file.scm

@@ -0,0 +1,95 @@
+(define (call/temp-file writer user)
+  (let ((fname #f))
+    (dynamic-wind
+      (lambda () (if fname (error "Can't wind back into a CALL/TEMP-FILE")
+		     (set! fname (create-temp-file))))
+      (lambda ()
+	(with-output-to-file fname writer)
+	(user fname))
+      (lambda () (if fname (delete-file fname))))))
+
+;;; Create a new temporary file and return its name.
+;;; The optional argument specifies the filename prefix to use, and defaults
+;;; to "/tmp/<pid>.", where <pid> is the current process' id. The procedure
+;;; scans through the files named <prefix>0, <prefix>1, ... until it finds a
+;;; filename that doesn't exist in the filesystem. It creates the file with 
+;;; permission #o600, and returns the filename.
+;;; 
+
+(define (create-temp-file . maybe-prefix)
+  (let ((oflags (bitwise-ior open/write
+			     (bitwise-ior open/create open/exclusive))))
+    (apply temp-file-iterate
+	   (lambda (fname)
+	     (close-fdes (open-fdes fname oflags #o600))
+	     fname)
+	   (if (null? maybe-prefix) '()
+	       (list (string-append (constant-format-string (car maybe-prefix))
+				    ".~a"))))))
+
+(define (initial-temp-file)
+  (let ((tmpdir (getenv "TMPDIR")))
+    (string-append
+     (if tmpdir
+	 tmpdir
+	 "/var/tmp")
+     "/"
+     (number->string (pid))
+     "~a")))
+
+(define *temp-file-template* (make-fluid 'not-initialized-temp-file-template))
+
+(define temp-file-reinitializer 
+  (make-reinitializer 
+   (lambda ()
+     (set-fluid! *temp-file-template* (initial-temp-file)))))
+
+(define (temp-file-iterate maker . maybe-template)
+  (let ((template (:optional maybe-template (fluid *temp-file-template*))))
+    (let loop ((i 0))
+      (if (> i 1000) (error "Can't create temp-file")
+	  (let ((fname (format #f template (number->string i))))
+	    (receive retvals (with-errno-handler
+			       ((errno data)
+				((errno/exist errno/acces) #f))
+			       (maker fname))
+	      (if (car retvals) (apply values retvals)
+		  (loop (+ i 1)))))))))
+
+
+
+;; Double tildes in S. 
+;; Using the return value as a format string will output exactly S.
+(define (constant-format-string s)	; Ugly code. Would be much clearer
+  (let* ((len (string-length s))	; if written with string SRFI.
+	 (tilde? (lambda (s i) (char=? #\~ (string-ref s i))))
+	 (newlen (do ((i (- len 1) (- i 1))
+		      (ans 0 (+ ans (if (tilde? s i) 2 1))))
+		     ((< i 0) ans)))
+	 (fs (make-string newlen)))
+    (let lp ((i 0) (j 0))
+      (cond ((< i len)
+	     (let ((j (cond ((tilde? s i) (string-set! fs j #\~) (+ j 1))
+			    (else j))))
+	       (string-set! fs j (string-ref s i))
+	       (lp (+ i 1) (+ j 1))))))
+    fs))
+
+
+;;; Roughly equivalent to (pipe).
+;;; Returns two file ports [iport oport] open on a temp file.
+;;; Use this when you may have to buffer large quantities between
+;;; writing and reading. Note that if the consumer gets ahead of the
+;;; producer, it won't hang waiting for input, it will just return
+;;; EOF. To play it safe, make sure that the producer runs to completion
+;;; before starting the consumer.
+;;;
+;;; The temp file is deleted before TEMP-FILE-CHANNEL returns, so as soon
+;;; as the ports are closed, the file's disk storage is reclaimed.
+
+(define (temp-file-channel)
+  (let* ((fname (create-temp-file))
+	 (iport (open-input-file fname))
+	 (oport (open-output-file fname)))
+    (delete-file fname)
+    (values iport oport)))

scsh/top.scm

@@ -323,7 +323,21 @@
       (lambda ()
 	;; environment,umask and cwd are already installed by resumers
 	;; c.f. {env,umask,env}-reinitializer in scsh.scm
-	(init-scsh-vars interactive?)
+	(init-home-directory 
+	 (cond ((getenv "HOME"))
+	       ;; loosing at this point would be really bad, so some
+	       ;; paranoia comes in order
+	       (else (call-with-current-continuation 
+		      (lambda (k)
+			(with-handler
+			 (lambda (condition more)
+			   (cond ((not interactive?)
+				  (display "Starting up with no home directory ($HOME).")
+				  (newline)))
+			   (k "/"))
+			 (lambda ()
+			   (user-info:home-dir (user-info (user-uid))))))))))
+	(init-exec-path-list interactive?)
 	(start-new-session context    
 			   (current-input-port)
 			   (current-output-port)

scsh/user-group.scm

@@ -0,0 +1,119 @@
+;;; User info
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record user-info
+  name uid gid home-dir shell
+
+  ;; Make user-info records print like #{user-info shivers}.
+  ((disclose ui)
+   (list "user-info" (user-info:name ui))))
+
+
+(import-os-error-syscall
+ %uid->user-info 
+ (uid user-info-record)
+ "user_info_uid")
+
+(import-os-error-syscall
+ %name->user-info 
+ (name user-info-record)
+ "user_info_name")
+
+(define (uid->user-info uid)
+  (let ((empty-user-info (make-user-info #f uid #f #f #f)))
+    (if (%uid->user-info uid empty-user-info)
+	empty-user-info
+	(error "Cannot get user's information" uid->user-info uid)))) 
+
+
+(define (name->user-info name)
+  (let ((empty-user-info (make-user-info name #f #f #f #f)))
+    (if (%name->user-info name empty-user-info)
+	empty-user-info
+	(error "Cannot get user's information" name->user-info name))))
+
+(define (user-info uid/name)
+  ((cond ((string?  uid/name) name->user-info)
+	 ((integer? uid/name) uid->user-info)
+	 (else (error "user-info arg must be string or integer" uid/name)))
+   uid/name))
+
+;;; Derived functions
+
+(define (->uid uid/name)
+  (user-info:uid (user-info uid/name)))
+
+(define (->username uid/name)
+  (user-info:name (user-info uid/name)))
+
+(define (%homedir uid/name)
+  (user-info:home-dir (user-info uid/name)))
+
+(define home-directory "")
+
+(define (init-home-directory home)
+  (set! home-directory home))
+
+(define (home-dir . maybe-user)
+  (if (pair? maybe-user)
+      (let ((user (car maybe-user)))
+	(ensure-file-name-is-nondirectory
+	    (or (%homedir user)
+		(error "Cannot get user's home directory"
+		       user))))
+      home-directory))
+
+;;; (home-file [user] fname)
+
+(define (home-file arg1 . maybe-arg2)
+  (receive (dir fname)
+	   (if (pair? maybe-arg2)
+	       (values (home-dir arg1) (car maybe-arg2))
+	       (values home-directory  arg1))
+    (string-append (file-name-as-directory dir) fname)))
+
+;;; Group info
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record group-info
+  name gid members
+
+  ;; Make group-info records print like #{group-info wheel}.
+  ((disclose gi) (list "group-info" (group-info:name gi))))
+
+(import-os-error-syscall
+ %gid->group-info 
+ (gid group-info-record)
+ "group_info_gid")
+
+(import-os-error-syscall
+ %name->group-info 
+ (name group-info-record)
+ "group_info_name")
+
+(define (gid->group-info  gid)
+  (let ((empty-group-info (make-group-info #f gid #f)))
+    (if (%gid->group-info gid empty-group-info)
+	empty-group-info
+	(error "Cannot get group's information for gid" gid))))
+							
+(define (name->group-info name)
+  (let ((empty-group-info (make-group-info name #f #f)))
+    (if (%name->group-info name empty-group-info)
+	empty-group-info
+	(error "Cannot get group's information for name" name))))
+
+(define (group-info gid/name)
+  ((cond ((string?  gid/name) name->group-info)
+	 ((integer? gid/name) gid->group-info)
+	 (else (error "group-info arg must be string or integer" gid/name)))
+   gid/name))
+
+;;; Derived functions
+
+(define (->gid name)
+  (group-info:gid (group-info name)))
+
+(define (->groupname gid)
+  (group-info:name (group-info gid)))
+

scsh/utilities.scm

@@ -1,6 +1,11 @@
 ;;; Random useful utilities.
 ;;; 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 (mapv f v)
   (let* ((len (vector-length v))
 	 (ans (make-vector len)))
@@ -131,4 +136,28 @@
 		(obtain-lock next)
 		(lp (list next) (delete next locks eq?))))))))
 	
-  
+;;; Should be moved to somewhere else
+(define (with-lock lock thunk)
+  (dynamic-wind 
+   (lambda ()
+     (release-lock lock))
+   thunk
+   (lambda ()
+     (release-lock lock))))
+
+(define (stringify thing)
+  (cond ((string? thing) thing)
+	((symbol? thing)
+	 (symbol->string thing))
+;	((symbol? thing)
+;	 (list->string (map char-downcase
+;			    (string->list (symbol->string thing)))))
+	((integer? thing)
+	 (number->string thing))
+	(else (error "Can only stringify strings, symbols, and integers."
+		     thing))))
+
+(define (bogus-substring-spec? s start end)
+  (or (< start 0)
+      (< (string-length s) end)
+      (< end start)))