[Process/Process Object: Finally, they compile...
clinton@unknownlamer.org**20100402165750
 Ignore-this: d231b4a65b31a3d6d7381d11c8f16e00
 ... but I seriously doubt they work
 * Process definitely does not work because I have not implemented the
   scsh file system interface
] move ./module/scsh/procobj.scm ./module/scsh/process-object.scm
hunk ./module/scsh/process-object.scm 3
+;;; Copyright (c) 2010 Clinton Ebadi
+
+;;; Renamed from procobj.scm for Guile Facade
+
+(define-module (scsh process-object)
+  #:use-module (scsh define-record)
+  #:use-module (scsh system-error)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 weak-vector)
+  #:export (proc
+	    proc:pid
+
+	    autoreap-policy
+
+	    ;; should these be exported from a different module? --clinton
+	    wait
+	    wait-any
+	    wait-process-group
+
+	    wait/poll
+	    wait/stopped-children))
hunk ./module/scsh/process-object.scm 45
+(define procobj-guardian-lock (make-mutex))
+(define %procobj-guardian (make-guardian))
+
+(define (procobj-guardian . args)
+  (with-mutex procobj-guardian-lock
+    (apply procobj-guardian args)))
+
hunk ./module/scsh/process-object.scm 56
-    (add-finalizer! procobj procobj-finalizer)
+    (procobj-guardian procobj)
hunk ./module/scsh/process-object.scm 59
-
hunk ./module/scsh/process-object.scm 68
-(define process-table (make-integer-table))
-(make-reinitializer (lambda ()
-		      (set! process-table (make-integer-table))))
+(define process-table (make-weak-value-hash-table ))
+(define process-table-lock (make-mutex))
hunk ./module/scsh/process-object.scm 71
-(define process-table-lock (make-lock))
hunk ./module/scsh/process-object.scm 72
-  (with-lock process-table-lock
-	     (lambda ()
-	       (weak-table-ref process-table n))))
+  (with-mutex process-table-lock
+    (hashv-ref process-table n)))
hunk ./module/scsh/process-object.scm 77
-	     (lambda ()
-	       (weak-table-set! process-table n val))))
+    (hashv-set! process-table n val)))
hunk ./module/scsh/process-object.scm 81
-	     (lambda ()
-	       (if (eq? (weak-table-ref process-table (proc:pid procobj))
-			procobj)
-		   (weak-table-set! process-table (proc:pid procobj) #f)))))
+    (if (eq? (hashv-ref process-table (proc:pid procobj))
+	     procobj)
+	(hashv-remove! process-table (proc:pid procobj)))))
hunk ./module/scsh/process-object.scm 88
-(define (pid->proc pid . maybe-probe?)
-  (let ((probe? (:optional maybe-probe? #f)))
-    (or (maybe-pid->proc pid)
-	(case probe?
-	  ((#f)     (error "Pid has no corresponding process object" pid))
-	  ((create) (new-child-proc pid))
-	  (else     #f)))))
+(define* (pid->proc pid probe?)
+  (or (maybe-pid->proc pid)
+      (case probe?
+	((#f)     (error "Pid has no corresponding process object" pid))
+	((create) (new-child-proc pid))
+	(else     #f))))
hunk ./module/scsh/process-object.scm 137
-;;; I'm really tired of opening everything (i.e. events) in scsh-level-0
-;;; this is here until someone (Olin !!!) cleans up the scsh modules
-
-(define next-sigevent (structure-ref sigevents next-sigevent))
-(define most-recent-sigevent (structure-ref sigevents most-recent-sigevent))
-
+(define *autoreap-policy* #f)	      ; Not exported from this module.
hunk ./module/scsh/process-object.scm 139
-(define *autoreap-policy* #f) ; Not exported from this module.
-
-(define (autoreap-policy . maybe-policy)
+(define* (autoreap-policy #:optional new-policy)
hunk ./module/scsh/process-object.scm 141
-    (if (pair? maybe-policy)
-	(let ((new-policy (car maybe-policy)))
-	  (cond ((pair? (cdr maybe-policy))
-		 (error "Too many args to autoreap-policy" maybe-policy))
-		((not (memq new-policy '(early late #f)))
-		 (error "Illegal autoreap policy." new-policy))
-		(else (set! *autoreap-policy* new-policy)
-		      (cond ((eq? new-policy 'early)
-			     (set-sigchld-handler! early-sigchld-handler)
-			     (set-post/gc-handler! reap-need-reaping))
+    (cond ((not (memq new-policy '(early late #f)))
+	   (error "Illegal autoreap policy." new-policy))
+	  (else (set! *autoreap-policy* new-policy)
+		(cond ((eq? new-policy 'early)
+		       (start-reaping)
+		       (set-sigchld-handler! early-sigchld-handler)
+		       (set-post/gc-handler! notify-reap-need-reaping))
hunk ./module/scsh/process-object.scm 149
-			    ((eq? new-policy 'late)
-			     (set-sigchld-handler! late-sigchld-handler)
-			     (set-post/gc-handler! reap-need-reaping))
+		      ((eq? new-policy 'late)
+		       (start-reaping)
+		       (set-sigchld-handler! late-sigchld-handler)
+		       (set-post/gc-handler! notify-reap-need-reaping))
hunk ./module/scsh/process-object.scm 154
-			    (else 
-			     (set-sigchld-handler! noauto-sigchld-handler)
-			     (set-post/gc-handler! 
-			      (lambda ()
-				#f))))))))
+		      (else
+		       (stop-reaping)
+		       (set-sigchld-handler! noauto-sigchld-handler)
+		       (set-post/gc-handler! 
+			(lambda ()
+			  #f))))))
hunk ./module/scsh/process-object.scm 169
-   (set! *post/gc-handler* handler))
+  (monitor
+   (remove-hook! after-gc-hook *post/gc-handler*)
+   (set! *post/gc-handler* handler)
+   (add-hook! after-gc-hook *post/gc-handler*)))
hunk ./module/scsh/process-object.scm 175
-  (set! set-post/gc-handler! really-set-post/gc-handler!)
-  (set-post/gc-handler! handler)
-  (spawn (lambda ()
-	   (let lp ((event (most-recent-sigevent)))
-	     (let ((next-event (next-sigevent event interrupt/post-gc)))
-	       (*post/gc-handler*)
- 	       (lp next-event))))
- 	 '*post/gc-handler*-thread))
+  (monitor
+   (set! set-post/gc-handler! really-set-post/gc-handler!)
+   (set-post/gc-handler! handler)))
hunk ./module/scsh/process-object.scm 181
+(define %sigchld-other-handler #f)
+
+;;; Used to notify `wait' that another child has died (seems a bit
+;;; convoluted for `really-wait' to never block, but I'm not sure why
+;;; it behaves that way and so am leaving it alone for now)
+(define sigchld-condition (make-condition-variable))
+
+(define (wait-for-sigchld lock)
+  (wait-condition-variable sigchld-condition lock))
+
+(define (%sigchld-handler)
+  (monitor ; not sure if this needs to be thread exclusive
+   (if (procedure? %sigchld-other-handler)
+       (%sigchld-other-handler))
+   (*sigchld-handler*)
+   (broadcast-condition-variable sigchld-condition)))
hunk ./module/scsh/process-object.scm 199
+
+;;; Attempts to coexist with other SIGCHLD handlers. Does not work if
+;;; the handler is written in C
hunk ./module/scsh/process-object.scm 203
-  (set! *sigchld-handler* handler))
+  (monitor
+   (let ((current-handler (car (sigaction SIGCHLD))))
+     (if (and (procedure? current-handler)
+	      (not (eq? current-handler %sigchld-handler)))
+	 (set! %sigchld-other-handler current-handler))
+     (sigaction SIGCHLD %sigchld-handler SA_NOCLDSTOP))
+   (set! *sigchld-handler* handler)))
hunk ./module/scsh/process-object.scm 211
-(define (with-autoreaping thunk)
-  (set! *autoreap-policy* 'early)
-  (run-as-long-as
-   (lambda ()
-     (let lp ((event (most-recent-sigevent)))
-       (let ((next-event (next-sigevent event interrupt/chld)))
-	 (*sigchld-handler*)
-	 (lp next-event))))
-   thunk
-   (structure-ref threads-internal spawn-on-root)
-   'auto-reaping))
+;;; Not implementing for now --clinton
+;; (define (with-autoreaping thunk)
+;;   (set! *autoreap-policy* 'early)
+;;   (run-as-long-as
+;;    (lambda ()
+;;      (let lp ((event (most-recent-sigevent)))
+;;        (let ((next-event (next-sigevent event interrupt/chld)))
+;; 	 (*sigchld-handler*)
+;; 	 (lp next-event))))
+;;    thunk
+;;    (structure-ref threads-internal spawn-on-root)
+;;    'auto-reaping))
hunk ./module/scsh/process-object.scm 228
-(define need-reaping-lock (make-lock))
+(define need-reaping-lock (make-mutex 'recursive))
+(define need-reaping-condition (make-condition-variable))
+(define need-reaping-thread #f)
+
+(define (start-reaping)
+  (cond (need-reaping-thread
+	 (cancel-thread need-reaping-thread)
+	 ;; should wake up the reap thread and cause the cancellation
+	 ;; to be delivered when relocking the need-reaping-lock
+	 (signal-condition-variable need-reaping-condition)
+	 (set! need-reaping-thread #f)))
+  (set! need-reaping-thread
+	(call-with-new-thread reap-need-reaping-process)))
+
+(define (notify-reap-need-reaping)
+  (signal-condition-variable need-reaping-condition))
hunk ./module/scsh/process-object.scm 246
-  (obtain-lock need-reaping-lock)
-  (set! need-reaping (cons pid need-reaping))
-  (release-lock need-reaping-lock))
+  (with-mutex need-reaping-lock
+    (set! need-reaping (cons pid need-reaping))))
hunk ./module/scsh/process-object.scm 250
-  (obtain-lock need-reaping-lock)
-  (set! need-reaping (delete pid need-reaping))
-  (release-lock need-reaping-lock))
+  (with-mutex need-reaping-lock
+    (set! need-reaping (delete pid need-reaping))))
hunk ./module/scsh/process-object.scm 253
-(define (reap-need-reaping)
-  (obtain-lock need-reaping-lock)
-  (set! need-reaping (filter (lambda (pid) (not (reap-pid pid))) need-reaping))
-  (release-lock need-reaping-lock))
+(define (reap-need-reaping-process)
+  (let reap-loop ()
+    (with-mutex need-reaping-lock
+      (wait-condition-variable need-reaping-condition need-reaping-lock)
+      (let finalize-procobjs ((procobj (procobj-guardian)))
+	(cond ((proc? procobj)
+	         (process-table-delete-procobj! procobj)
+		 (if (not (proc:finished? procobj))
+		     (need-reaping-add! (proc:pid procobj)))
+		 (finalize-procobjs (procobj-guardian)))))
+      (set! need-reaping (filter (lambda (pid) (not (reap-pid pid))) need-reaping)))
+    (reap-loop)))
hunk ./module/scsh/process-object.scm 269
-  (with-lock 
-   wait-lock
-   (lambda ()
-     (let ((status (atomic-wait pid wait/poll)))
-       (if status 
-	   (waited-by-reap pid status))
-       status))))
+  (with-mutex wait-lock
+    (let ((status (atomic-wait pid wait/poll)))
+      (if status 
+	  (waited-by-reap pid status))
+      status)))
hunk ./module/scsh/process-object.scm 284
-;;; Finalizer for procobjs
-;;; 
-(define (procobj-finalizer procobj)
-  (process-table-delete-procobj! procobj)
-  (if (not (proc:finished? procobj))
-      (need-reaping-add! (proc:pid procobj))))
-
-
hunk ./module/scsh/process-object.scm 290
-    (obtain-lock wait-lock)
+    (lock-mutex wait-lock)
hunk ./module/scsh/process-object.scm 295
-		 (release-lock wait-lock)
+		 (unlock-mutex wait-lock)
hunk ./module/scsh/process-object.scm 300
-	    (release-lock wait-lock)
+	    (unlock-mutex wait-lock)
hunk ./module/scsh/process-object.scm 331
+(define wait/poll WNOHANG)
+(define wait/stopped-children WUNTRACED)
+
hunk ./module/scsh/process-object.scm 337
-(define wait-lock (make-lock))
+(define wait-lock (make-mutex))
hunk ./module/scsh/process-object.scm 339
-(define (wait pid/proc . maybe-flags)
-  (let* ((flags (:optional maybe-flags 0))
-	 (proc (->proc pid/proc))
+(define* (wait pid/proc #:optional (flags 0))
+  (let* ((proc (->proc pid/proc))
hunk ./module/scsh/process-object.scm 350
-	       
hunk ./module/scsh/process-object.scm 351
-		;; we have to block and hence use the event system
-		(let lp ((pre-event pre-event))
+		;; blocking
+		(let lp ()
+		  (wait-for-sigchld wait-lock)
hunk ./module/scsh/process-object.scm 356
-			(else
-			 (release-lock wait-lock)
-			 (let ((next-event (next-sigevent pre-event interrupt/chld)))
-			   (obtain-lock wait-lock)
-			   (lp next-event))))))
+			(else (lp)))))
hunk ./module/scsh/process-object.scm 358
-		
-
+	
hunk ./module/scsh/process-object.scm 373
-      (%wait-pid pid flags)
+      (waitpid pid flags)
hunk ./module/scsh/process-object.scm 379
-;;; 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)))
-
hunk ./module/scsh/process-object.scm 385
-	   (push-reaped-proc proc)
-	   ))))
-
+	   (push-reaped-proc proc)))))
hunk ./module/scsh/process-object.scm 409
-(define (wait-any . maybe-flags)
-  (let ((flags (:optional maybe-flags 0)))
-    (if (zero? (bitwise-and flags wait/poll))
-	(begin
-	  (receive (pid status) 
-	     ;; before we maybe block via placeholder-value
-	     ;; do a really-wait-any for the ones, missed by 'late
+(define* (wait-any #:optional (flags 0))
+  (if (zero? (bitwise-and flags wait/poll))
+      (begin
+	(receive (pid status) 
+	    ;; before we maybe block via placeholder-value
+	    ;; do a really-wait-any for the ones, missed by 'late
hunk ./module/scsh/process-object.scm 416
-	    (if (not pid)
-		(let ((win (get-reaped-proc!)))
-		  (values win (placeholder-value (proc:status win))))
-		(values pid status))))
+	  (if (not pid)
+	      (let ((win (get-reaped-proc!)))
+		(values win (placeholder-value (proc:status win))))
+	      (values pid status))))
hunk ./module/scsh/process-object.scm 421
-	;; The rest of this is quite crude and can be safely ignored. -df
-	;; JMG: wait-any is crude and so its implementation
-	;; It got even worse, now that we have this fu*$#%g 'late
-	(if (maybe-obtain-lock reaped-proc-pop-lock)
-	    (if (eq? reaped-proc-head reaped-proc-tail)
-		;;; due to 'late we cannot be sure, that they all have been
-		;;; reaped
-		(begin
-		  (release-lock reaped-proc-pop-lock)
-		  (really-wait-any flags))
-		(let* ((retnode (placeholder-value reaped-proc-head))
-		       (retval (weak-pointer-ref (reaped-proc:proc retnode))))
-		  (set! reaped-proc-head (reaped-proc:next retnode))
-		  (release-lock reaped-proc-pop-lock)
-		  (if retval
-		      (values retval (placeholder-value (proc:status retval)))
-		      (values #f #f))))
-	    (values #f #f)))))
+      ;; The rest of this is quite crude and can be safely ignored. -df
+      ;; JMG: wait-any is crude and so its implementation
+      ;; It got even worse, now that we have this fu*$#%g 'late
+      ;; ... maybe cleaned up, but probably just b0rked further --clinton
+      (if (reaped-proc-available?)
+	  (really-wait-any flags)
+	  (let ((proc (weak-pointer-ref (reaped-proc:proc (pop-reaped-proc)))))
+	    (if proc
+		(values proc (placeholder-value (proc:status proc)))
+		(values #f #f))))))
hunk ./module/scsh/process-object.scm 457
-(define (wait-process-group . args)
-  (let-optionals args ((proc-group 0) (flags 0))
-    (let ((proc-group (cond ((integer? proc-group) proc-group)
-			     ((proc? proc-group)    (proc:pid proc-group))
-			     (else (error "Illegal argument" wait-process-group
-					  proc-group))))
-	  (win (lambda (pid status)
-		 (let ((proc (pid->proc pid 'create)))
-		   (if proc (waited-by-wait proc status))
-		   (values proc status)))))
-      ;; save the event before we check for finished
-      (let ((pre-event (most-recent-sigevent)))
-	(receive (pid status) 
-          (%wait-process-group proc-group (bitwise-ior flags wait/poll))
-          (cond (pid
-		 (win pid status))
-		((zero? (bitwise-and flags wait/poll))
-		 ;; we have to block and hence use the event system
-		 (let lp ((pre-event pre-event))
-		   (receive (pid status) 
-		      (%wait-process-group proc-group (bitwise-ior flags wait/poll))
-		      (if pid
-			  (win pid status)
-			  (lp (next-sigevent pre-event interrupt/chld))))))
-		(else 
-		 (values #f status))))))))
+(define* (wait-process-group #:optional (proc-group 0) (flags 0))
+  (let ((proc-group (cond ((integer? proc-group) proc-group)
+			  ((proc? proc-group)    (proc:pid proc-group))
+			  (else (error "Illegal argument" wait-process-group
+				       proc-group))))
+	(win (lambda (pid status)
+	       (let ((proc (pid->proc pid 'create)))
+		 (if proc (waited-by-wait proc status))
+		 (values proc status)))))
+    (receive (pid status) 
+	(%wait-process-group proc-group (bitwise-ior flags wait/poll))
+      (cond (pid
+	     (win pid status))
+	    ((zero? (bitwise-and flags wait/poll))
+	     (let lp ()
+	       (wait-for-sigchld)
+	       (receive (pid status) 
+		   (%wait-process-group proc-group (bitwise-ior flags wait/poll))
+		 (if pid
+		     (win pid status)
+		     (lp)))))
+	    (else 
+	     (values #f status))))))
hunk ./module/scsh/process-object.scm 484
-;;; (%wait-any flags) (%wait-pid pid flags) (%wait-process-group pgrp flags)
+;;; (%wait-any flags) (waitpid pid flags) (%wait-process-group pgrp flags)
hunk ./module/scsh/process-object.scm 486
-;;; Direct interfaces to waitpid(2) call. As opposed to %wait-pid this
+;;; Direct interfaces to waitpid(2) call. As opposed to waitpid this
hunk ./module/scsh/process-object.scm 496
-    ((errno/child)
+    ((ECHILD)
hunk ./module/scsh/process-object.scm 499
-       (%wait-pid -1 flags)
+       (waitpid WAIT_ANY flags)
hunk ./module/scsh/process-object.scm 509
-    ((errno/child)
+    ((ECHILD)
hunk ./module/scsh/process-object.scm 512
-	(%wait-pid (- pgrp) flags)
+	(waitpid (- pgrp) flags)
hunk ./module/scsh/process-object.scm 550
+;;; Shim for Schem48 weak-pointer interface
+(define (make-weak-pointer datum)
+  (weak-vector datum))
+(define (weak-pointer-ref pointer)
+  (vector-ref pointer 0))
+(define (weak-pointer? pointer)
+  (and (weak-vector? pointer) (vector-length pointer 1)))
+
hunk ./module/scsh/process-object.scm 560
-(define reaped-proc-push-lock (make-lock))
-(define reaped-proc-pop-lock (make-lock))          ;;; Zippy sez: pop lock!
+(define reaped-proc-push-lock (make-mutex))
+(define reaped-proc-pop-lock (make-mutex))          ;;; Zippy sez: pop lock!
+
+(define (reaped-proc-available?)
+  (with-mutex reaped-proc-pop-lock
+    (not (eq? reaped-proc-head reaped-proc-tail))))
hunk ./module/scsh/process-object.scm 568
-  (obtain-lock reaped-proc-push-lock)
+  (lock-mutex reaped-proc-push-lock)
hunk ./module/scsh/process-object.scm 571
-    (add-finalizer! proc (make-reaped-proc-finalizer push-me))
+    ;; doesn't look like this is needed. A few extra reaped procs may
+    ;; live on, but get-reaped-proc! will skip them. Doing this with
+    ;; guardian would be a huge PITA as well. --clinton
+    ;;(add-finalizer! proc (make-reaped-proc-finalizer push-me))
hunk ./module/scsh/process-object.scm 576
-  (release-lock reaped-proc-push-lock))
-
-(define (make-reaped-proc-finalizer push-me)
-  (lambda ignore 
-    (remove-reaped-proc push-me)))
-
-(define (remove-reaped-proc reaped-proc)
-  (spawn (lambda ()                 ;This is blocking, so should run by itself
-	   (set-reaped-proc:prev
-	    (placeholder-value (reaped-proc:next reaped-proc))
-	    (reaped-proc:prev reaped-proc))
-	   (set-reaped-proc:next
-	    (reaped-proc:prev reaped-proc)
-	    (reaped-proc:next reaped-proc)))
-  	 "reaped-proc-removing-thread"))
+  (unlock-mutex reaped-proc-push-lock))
hunk ./module/scsh/process-object.scm 579
-  (obtain-lock reaped-proc-pop-lock)        ;;; pop lock pop lock pop lock!
+  (lock-mutex reaped-proc-pop-lock)        ;;; pop lock pop lock pop lock!
hunk ./module/scsh/process-object.scm 582
-    (release-lock reaped-proc-pop-lock)
+    (unlock-mutex reaped-proc-pop-lock)
hunk ./module/scsh/process-object.scm 585
-
-
hunk ./module/scsh/process-object.scm 595
-
hunk ./module/scsh/process.scm 1
-
+;;; SCSH Processes -- Part of Guile Facade (formerly part of SCSH)
+;;; See COPYING for full Copyrights
+;;; Guile specific changes Copyright (c) 2010 Clinton Ebadi
+
+(define-module (scsh process)
+  #:use-module (scsh process-object)
+  #:use-module (scsh utilities)
+  #:use-module (srfi srfi-39)
+  #:use-module (ice-9 optargs)
+  #:export (exec
+	    exec-path
+	    exec/env
+	    exec-path/env
+
+	    exec-path-search
+
+	    call-terminally
+	    halts? ; likewise... nah, probably not
+
+	    fork
+	    %fork
+
+	    fork/pipe
+	    %fork/pipe
+	    fork/pipe+
+	    %fork/pipe+
+	    pipe*
+
+	    process-sleep
+	    process-sleep-until))
+
+;;; Process
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (%exec prog arg-list env)
+  (let ((argv (map stringify arg-list))
+	(prog (stringify prog))
+	(env (if (eq? env #t) (environ) env)))
+    (apply execle prog env argv)))
+
+;;; 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)
+  (%exec prog (cons prog arglist) env))
+
+;;; Some globals:
+(define exec-path-list)
+
+(define (init-exec-path-list quietly?)
+  (set! exec-path-list
+	(make-parameter
+	 (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))))))))
+
+;;; 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)
+  (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 (cons prog (map stringify arglist))))
+	  (for-each (lambda (dir)
+		      (let ((binary (string-append dir "/" prog)))
+			(apply execlv binary env argv)))
+		    (exec-path-list))))))
+   
+(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 PRIMITIVE-FORK.
+
+(define (fork . stuff)
+  (apply fork-1 #t stuff))
+
+(define (%fork . stuff)
+  (apply fork-1 #f stuff))
+
+(define* (fork-1 clear-interactive? #:optional thunk)
+  (really-fork clear-interactive?
+	       thunk))
+
+(define (really-fork clear-interactive? maybe-thunk)
+  (let ((proc #f))
+    (if clear-interactive?
+	(flush-all-ports))
+
+    ;; fixme: A warning from the scsh source:
+    ;;
+    ;; 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 PRIMITIVE-FORK and NEW-CHILD-PROC
+    ;; operations.
+    ;;
+    ;; ... I am unsure if guile can deal with this or if it is even a
+    ;; problem --clinton
+    
+    (let ((pid (primitive-fork)))
+      (if (zero? pid)				
+	  ;; Child
+	  (if maybe-thunk
+	      (call-and-exit maybe-thunk))
+	  ;; Parent
+	  (new-child-proc pid)))))
+
+
+(define (call-terminally thunk)
+  (thunk)
+  (exit 0))
+
+
+(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-optional 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)
+               (set-current-input-port! r))
+	      (else		; Child
+	       (close r)
+               (move->fdes w 1)
+               (if maybe-thunk
+                   (parameterize ((current-output-port w))
+		     w
+                    (call-and-exit maybe-thunk))
+                   (set-current-output-port! w))))
+	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-optional 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)
+
+;;; Miscellaneous
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (process-sleep secs) (process-sleep-until (+ secs (current-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))))
+    (sleep (- (inexact->exact (floor when)) (current-time)))))