[Rerecord changes to procobj/process
clinton@unknownlamer.org**20100403075719
 Ignore-this: e1d2dbb3895bf844d2cd7de2446550e9
 For the sake of documenting the history of the code
] 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
hunk ./module/scsh/process.scm 5
-;;; 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-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
hunk ./module/scsh/process.scm 15
-(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)))
+	    exec-path-search
+
+	    call-terminally
+	    halts? ; likewise... nah, probably not
hunk ./module/scsh/process.scm 20
+	    fork
+	    %fork
hunk ./module/scsh/process.scm 23
-(import-os-error-syscall exit/errno ; errno -- misnomer.
-  (status) "scsh_exit")
+	    fork/pipe
+	    %fork/pipe
+	    fork/pipe+
+	    %fork/pipe+
+	    pipe*
hunk ./module/scsh/process.scm 29
-(import-os-error-syscall %exit/errno ; errno -- misnomer
-  (status) "scsh__exit")
+	    process-sleep
+	    process-sleep-until))
hunk ./module/scsh/process.scm 32
-(define (%exit . maybe-status)
-  (%exit/errno (:optional maybe-status 0))
-  (error "Yikes! %exit returned."))
+;;; Process
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
hunk ./module/scsh/process.scm 35
-(import-os-error-syscall %%fork () "scsh_fork")
+(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)))
hunk ./module/scsh/process.scm 65
-  (with-resources-aligned 
-   (list environ-resource cwd-resource umask-resource euid-resource egid-resource)
-   (lambda ()
-     (%exec prog (cons prog arglist) env))))
+  (%exec prog (cons prog arglist) env))
hunk ./module/scsh/process.scm 72
-	(make-preserved-thread-fluid 
+	(make-parameter
hunk ./module/scsh/process.scm 94
-;(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))))
-
hunk ./module/scsh/process.scm 100
-  (with-resources-aligned 
-   (list environ-resource cwd-resource umask-resource euid-resource egid-resource)
-   (lambda ()
-     (let ((prog (stringify prog)))
-       (if (string-index prog #\/)
+  (let ((prog (stringify prog)))
+    (if (string-index prog #\/)
hunk ./module/scsh/process.scm 103
-	   ;; Contains a slash -- no path search.
-	   (%exec prog (cons prog arglist) env)
+	;; Contains a slash -- no path search.
+	(%exec prog (cons prog arglist) env)
hunk ./module/scsh/process.scm 106
-	   ;; 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))))
+	;; 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))))))
hunk ./module/scsh/process.scm 120
-;;; Assumes niladic primitive %%FORK.
+;;; Assumes niladic primitive PRIMITIVE-FORK.
hunk ./module/scsh/process.scm 128
-(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* (fork-1 clear-interactive? #:optional thunk)
+  (really-fork clear-interactive?
+	       thunk))
hunk ./module/scsh/process.scm 132
-(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 ()
+(define (really-fork clear-interactive? maybe-thunk)
+  (let ((proc #f))
+    (if clear-interactive?
+	(flush-all-ports))
hunk ./module/scsh/process.scm 137
-       (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)))))
hunk ./module/scsh/process.scm 158
-       ;; 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.
hunk ./module/scsh/process.scm 159
-       (((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-terminally thunk)
+  (thunk)
+  (exit 0))
hunk ./module/scsh/process.scm 184
-  (let-optionals rest ((maybe-thunk #f)
-		       (no-new-command-level? #f))
+  (let-optional rest ((maybe-thunk #f)
+		      (no-new-command-level? #f))
hunk ./module/scsh/process.scm 196
-                   (with-current-output-port
-                    w
+                   (parameterize ((current-output-port w))
+		     w
hunk ./module/scsh/process.scm 214
-  (let-optionals rest ((maybe-thunk #f)
-		       (no-new-command-level? #f))
+  (let-optional rest ((maybe-thunk #f)
+		      (no-new-command-level? #f))
hunk ./module/scsh/process.scm 271
-; SIGTSTP blows s48 away. ???
-(define (suspend) (signal-process 0 signal/stop))
-
-
hunk ./module/scsh/process.scm 274
-;;; 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 secs) (process-sleep-until (+ secs (current-time))))
hunk ./module/scsh/process.scm 279
-    (let lp ()
-      (or (%sleep-until when) (lp)))))
-
-(import-os-error-syscall %sleep-until (secs) "sleep_until")
+    (sleep (- (inexact->exact (floor when)) (current-time)))))