From b7e6e25195ecef9c37c21173acc9cf2c355dd6e8 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Mon, 1 Oct 2012 20:11:11 +0100
Subject: Fix run/port* so it doesn't replace the input port when in the REPL. 
 Unfortunately, no test for it

---
 scsh-process.scm | 44 +++++++++++++++++++++++++++++++-------------
 1 file changed, 31 insertions(+), 13 deletions(-)

(limited to 'scsh-process.scm')

diff --git a/scsh-process.scm b/scsh-process.scm
index 50c2431..6102c4d 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -44,7 +44,8 @@
    ;; macros
    run/collecting run/string run/strings run/port run/file run/sexp run/sexps
    || &&
-   (& maybe-symbol->string) (run maybe-symbol->string) (exec-epf maybe-symbol->string))
+   (& run-final-thunk maybe-symbol->string)
+   (run maybe-symbol->string) (exec-epf maybe-symbol->string))
 
 (import chicken scheme data-structures)
 
@@ -61,6 +62,17 @@
 (define (fork/pipe #!optional thunk)
   (fork/pipe+ '((1 2 0)) thunk))
 
+;; Run a thunk and exit 0 after the thunk returns.
+;; If an exception occurs, handle it and exit 1.
+(define (run-final-thunk thunk)
+  (handle-exceptions exn
+    ;; TODO: Figure out how SCSH does this.  It shows the error
+    ;; on stderr in the REPL, but then still quits it.
+    ;; If we just invoke current-handler, it'll get a second REPL
+    (begin (print-error-message exn) (exit 1))
+    (thunk)
+    (exit 0)))
+
 (define (fork/pipe+ conns #!optional thunk)
   ;; Blergh, this is silly overhead we don't really need
   (let* ((from-fds (map (lambda (x) (drop-right x 1)) conns))
@@ -79,7 +91,7 @@
                       ;; Not needed anymore after duplication is complete.
                       (file-close (cadr p)))
                     pipe-pairs from-fds)
-          (if thunk (begin (thunk) (exit 0)) pid))
+          (if thunk (run-final-thunk thunk) pid))
         (begin                          ; Parent
           (for-each (lambda (p to-fd)
                       ;; Close sending end in parent.
@@ -113,11 +125,21 @@
     (apply values (fork/pipe+ conns thunk) temp-files)))
 
 (define (run/port* thunk)
-  (fork/pipe (lambda ()
-               (with-output-to-port (open-output-file* 1)
-                 (lambda ()
-                   (with-error-output-to-port (open-output-file* 2) thunk)))))
-  (open-input-file* 0))
+  (receive (in out)
+    (create-pipe)
+    (process-fork
+     (lambda ()
+       (run-final-thunk
+        (lambda ()
+          (file-close in)
+          (duplicate-fileno out 1)
+          (duplicate-fileno out 2)
+          (with-output-to-port (open-output-file* out)
+            (lambda ()
+              (with-error-output-to-port (open-output-file* out) thunk)))))))
+    (file-close out)
+    (open-input-file* in)))
+
 (define (run/file* thunk)
   (let* ((temp-file (create-temporary-file)))
     (process-wait                       ; This is peculiar
@@ -129,6 +151,7 @@
                       (lambda ()
                         (with-error-output-to-port (open-output-file* 2) thunk)))))))
     temp-file))
+
 (define (run/string* thunk)
   (read-string #f (run/port* thunk)))
 (define (run/strings* thunk)
@@ -175,12 +198,7 @@
   (syntax-rules ()
     ((_ ?epf ...)
      (process-fork (lambda ()
-                     (handle-exceptions exn
-                       ;; TODO: Figure out how SCSH does this.  It shows the error
-                       ;; on stderr in the REPL, but then still quits it.
-                       ;; If we just invoke current-handler, it'll get a second REPL
-                       (begin (print-error-message exn) (exit 1))
-                       (exec-epf ?epf ...)))))))
+                     (run-final-thunk (lambda () (exec-epf ?epf ...))))))))
 
 (define-syntax run
   (syntax-rules ()
-- 
cgit v1.2.3