[Actually import process.scm from scsh
clinton@unknownlamer.org**20100403075530
 Ignore-this: fe23638c731ff79863ce5c57df544f05
] move ./module/scsh/procobj.scm ./module/scsh/process-object.scm
hunk ./module/scsh/process.scm 1
-
+
+;;; 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)
+               (set-current-input-port! r))
+	      (else		; Child
+	       (close r)
+               (move->fdes w 1)
+               (if maybe-thunk
+                   (with-current-output-port
+                    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-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")