+ Fixed small bug in fork: command level wasn't resumed in the no-thunk case.

+ Optional continue-threads argument for fork/pipe and fork/pipe+

scsh/scsh.scm

@@ -22,65 +22,69 @@
 ;;; the parent's stdin to the child's stdout. This function side-effects
 ;;; the parent by changing his stdin.
 
-(define (fork/pipe . maybe-thunk)
+(define (fork/pipe . stuff)
-  (really-fork/pipe fork maybe-thunk))
+  (really-fork/pipe fork stuff))
 
-(define (%fork/pipe . maybe-thunk)
+(define (%fork/pipe . stuff)
-  (really-fork/pipe %fork maybe-thunk))
+  (really-fork/pipe %fork stuff))
   
 ;;; Common code for FORK/PIPE and %FORK/PIPE.
-(define (really-fork/pipe forker maybe-thunk)
+(define (really-fork/pipe forker rest)
-  (receive (r w) (pipe)
+  (let-optionals rest ((maybe-thunk #f)
-    (let ((proc (forker)))
+		       (no-new-command-level? #f))
-      (cond (proc		; Parent
+    (receive (r w) (pipe)
-	     (close w)
+      (let ((proc (forker #f no-new-command-level?)))
-	     (move->fdes r 0))
+	(cond (proc		; Parent
-	    (else		; Child
+	       (close w)
-	     (close r)
+	       (move->fdes r 0))
-	     (move->fdes w 1)
+	      (else		; Child
-	     (if (pair? maybe-thunk)
+	       (close r)
-		 (call-terminally (car maybe-thunk)))))
+	       (move->fdes w 1)
-      proc)))
+	       (if maybe-thunk
+		   (call-terminally maybe-thunk))))
+	proc))))
 
 
 ;;; FORK/PIPE with a connection list.
 ;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t)
 
-(define (%fork/pipe+ conns . maybe-thunk)
+(define (%fork/pipe+ conns . stuff)
-  (really-fork/pipe+ %fork conns maybe-thunk))
+  (really-fork/pipe+ %fork conns stuff))
 
-(define (fork/pipe+ conns . maybe-thunk)
+(define (fork/pipe+ conns . stuff)
-  (really-fork/pipe+ fork conns maybe-thunk))
+  (really-fork/pipe+ fork conns stuff))
 
 ;;; Common code.
-(define (really-fork/pipe+ forker conns maybe-thunk)
+(define (really-fork/pipe+ forker conns rest)
-  (let* ((pipes (map (lambda (conn) (call-with-values pipe cons))
+  (let-optionals rest ((maybe-thunk #f)
-		     conns))
+		       (no-new-command-level? #f))
-	 (rev-conns (map reverse conns))
+    (let* ((pipes (map (lambda (conn) (call-with-values pipe cons))
-	 (froms (map (lambda (conn) (reverse (cdr conn)))
+		       conns))
-		     rev-conns))
+	   (rev-conns (map reverse conns))
-	 (tos (map car rev-conns)))
+	   (froms (map (lambda (conn) (reverse (cdr conn)))
+		       rev-conns))
+	   (tos (map car rev-conns)))
 
-    (let ((proc (forker)))
+      (let ((proc (forker #f no-new-command-level?)))
-      (cond (proc			; Parent
+	(cond (proc			; Parent
-	     (for-each (lambda (to r/w)
+	       (for-each (lambda (to r/w)
-			 (let ((w (cdr r/w))
+			   (let ((w (cdr r/w))
-			       (r (car r/w)))
+				 (r (car r/w)))
-			   (close w)
+			     (close w)
-			   (move->fdes r to)))
+			     (move->fdes r to)))
-		       tos pipes))
+			 tos pipes))
 
-	    (else		; Child
+	      (else			; Child
-	     (for-each (lambda (from r/w)
+	       (for-each (lambda (from r/w)
-			 (let ((r (car r/w))
+			   (let ((r (car r/w))
-			       (w (cdr r/w)))
+				 (w (cdr r/w)))
-			   (close r)
+			     (close r)
-			   (for-each (lambda (fd) (dup w fd)) from)
+			     (for-each (lambda (fd) (dup w fd)) from)
-			   (close w))) ; Unrevealed ports win.
+			     (close w))) ; Unrevealed ports win.
-		       froms pipes)
+			 froms pipes)
-	     (if (pair? maybe-thunk)
+	       (if (pair? maybe-thunk)
-		 (call-terminally (car maybe-thunk)))))
+		   (call-terminally (car maybe-thunk)))))
-      proc)))
+	proc))))
 
 (define (tail-pipe a b)
   (fork/pipe a)
@@ -924,7 +928,7 @@
   (with-env-aligned*			; not neccessary here but doing it on exec
 					; genereates no cache in the parent
    (lambda ()
-     (let ((proc 'uninitialized)
+     (let ((proc #f)
 	   (maybe-push
 	    (if new-command-level?
 		(lambda (thunk)
@@ -951,7 +955,10 @@
 		      (if (and (session-started?) clear-interactive?)
 			  (set-batch-mode?! #t)) ; Children are non-interactive.
 		      (if maybe-thunk
-			  (call-terminally maybe-thunk)))
+			  (call-terminally maybe-thunk)
+			  (if new-command-level?
+			    (proceed-with-command-level
+			     (cadr (command-levels))))))
 		    ;; Parent
 		    (begin
 		      (set! proc (new-child-proc pid))