1.0.12.13: sequence optimizations: SUBSEQ, part 3

[sbcl.git] / src / code / run-program.lisp

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index 537b367..5c4f9fc 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -141,7 +141,6 @@
                      (not (zerop (ldb (byte 1 7) status)))))))))
 \f
 ;;;; process control stuff
                      (not (zerop (ldb (byte 1 7) status)))))))))
 \f
 ;;;; process control stuff

-#-win32

 (defvar *active-processes* nil
   #+sb-doc
   "List of process structures for all active processes.")
 (defvar *active-processes* nil
   #+sb-doc
   "List of process structures for all active processes.")

@@ -153,11 +152,11 @@
 ;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a
 ;;; mutex is needed. More importantly the sigchld signal handler also
 ;;; accesses it, that's why we need without-interrupts.
 ;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a
 ;;; mutex is needed. More importantly the sigchld signal handler also
 ;;; accesses it, that's why we need without-interrupts.

-#-win32

 (defmacro with-active-processes-lock (() &body body)
 (defmacro with-active-processes-lock (() &body body)

-  `(without-interrupts
-    (sb-thread:with-mutex (*active-processes-lock*)
-      ,@body)))
+  #-win32
+  `(sb-thread::call-with-system-mutex (lambda () ,@body) *active-processes-lock*)
+  #+win32
+  `(progn ,@body))

 
 (defstruct (process (:copier nil))
   pid                 ; PID of child process
 
 (defstruct (process (:copier nil))
   pid                 ; PID of child process

@@ -187,12 +186,16 @@
 #+sb-doc
 (setf (documentation 'process-pid 'function) "The pid of the child process.")
 
 #+sb-doc
 (setf (documentation 'process-pid 'function) "The pid of the child process.")
 

+#+win32
+(define-alien-routine ("GetExitCodeProcess@8" get-exit-code-process)
+    int
+  (handle unsigned) (exit-code unsigned :out))
+

 (defun process-status (process)
   #+sb-doc
   "Return the current status of PROCESS.  The result is one of :RUNNING,
    :STOPPED, :EXITED, or :SIGNALED."
 (defun process-status (process)
   #+sb-doc
   "Return the current status of PROCESS.  The result is one of :RUNNING,
    :STOPPED, :EXITED, or :SIGNALED."

-  #-win32
-  (get-processes-status-changes)  
+  (get-processes-status-changes)

   (process-%status process))
 
 #+sb-doc
   (process-%status process))
 
 #+sb-doc

@@ -228,12 +231,11 @@ The function is called with PROCESS as its only argument.")
 (setf (documentation 'process-plist  'function)
       "A place for clients to stash things.")
 
 (setf (documentation 'process-plist  'function)
       "A place for clients to stash things.")
 

-#-win32

 (defun process-wait (process &optional check-for-stopped)
   #+sb-doc
 (defun process-wait (process &optional check-for-stopped)
   #+sb-doc

-  "Wait for PROCESS to quit running for some reason.
-   When CHECK-FOR-STOPPED is T, also returns when PROCESS is
-   stopped.  Returns PROCESS."
+  "Wait for PROCESS to quit running for some reason. When
+CHECK-FOR-STOPPED is T, also returns when PROCESS is stopped. Returns
+PROCESS."

   (loop
       (case (process-status process)
         (:running)
   (loop
       (case (process-status process)
         (:running)

@@ -298,7 +300,6 @@ The function is called with PROCESS as its only argument.")
             (t
              t)))))
 
             (t
              t)))))
 

-#-win32

 (defun process-alive-p (process)
   #+sb-doc
   "Return T if PROCESS is still alive, NIL otherwise."
 (defun process-alive-p (process)
   #+sb-doc
   "Return T if PROCESS is still alive, NIL otherwise."

@@ -308,16 +309,19 @@ The function is called with PROCESS as its only argument.")
         t
         nil)))
 
         t
         nil)))
 

-#-win32

 (defun process-close (process)
   #+sb-doc
 (defun process-close (process)
   #+sb-doc

-  "Close all streams connected to PROCESS and stop maintaining the status slot."
+  "Close all streams connected to PROCESS and stop maintaining the
+status slot."

   (macrolet ((frob (stream abort)
                `(when ,stream (close ,stream :abort ,abort))))
   (macrolet ((frob (stream abort)
                `(when ,stream (close ,stream :abort ,abort))))

-    (frob (process-pty    process)   t) ; Don't FLUSH-OUTPUT to dead process, ..
-    (frob (process-input  process)   t) ; .. 'cause it will generate SIGPIPE.
+    #-win32
+    (frob (process-pty process) t)   ; Don't FLUSH-OUTPUT to dead process,
+    (frob (process-input process) t) ; .. 'cause it will generate SIGPIPE.

     (frob (process-output process) nil)
     (frob (process-output process) nil)

-    (frob (process-error  process) nil))
+    (frob (process-error process) nil))
+  ;; FIXME: Given that the status-slot is no longer updated,
+  ;; maybe it should be set to :CLOSED, or similar?

   (with-active-processes-lock ()
    (setf *active-processes* (delete process *active-processes*)))
   process)
   (with-active-processes-lock ()
    (setf *active-processes* (delete process *active-processes*)))
   process)

@@ -328,25 +332,47 @@ The function is called with PROCESS as its only argument.")
   (declare (ignore ignore1 ignore2 ignore3))
   (get-processes-status-changes))
 
   (declare (ignore ignore1 ignore2 ignore3))
   (get-processes-status-changes))
 

-#-win32

 (defun get-processes-status-changes ()
 (defun get-processes-status-changes ()

+  #-win32

   (loop
   (loop

-      (multiple-value-bind (pid what code core)
-          (wait3 t t)
-        (unless pid
-          (return))
-        (let ((proc (with-active-processes-lock ()
-                      (find pid *active-processes* :key #'process-pid))))
-          (when proc
-            (setf (process-%status proc) what)
-            (setf (process-exit-code proc) code)
-            (setf (process-core-dumped proc) core)
-            (when (process-status-hook proc)
-              (funcall (process-status-hook proc) proc))
-            (when (position what #(:exited :signaled))
-              (with-active-processes-lock ()
-                (setf *active-processes*
-                      (delete proc *active-processes*)))))))))
+   (multiple-value-bind (pid what code core)
+       (wait3 t t)
+     (unless pid
+       (return))
+     (let ((proc (with-active-processes-lock ()
+                   (find pid *active-processes* :key #'process-pid))))
+       (when proc
+         (setf (process-%status proc) what)
+         (setf (process-exit-code proc) code)
+         (setf (process-core-dumped proc) core)
+         (when (process-status-hook proc)
+           (funcall (process-status-hook proc) proc))
+         (when (position what #(:exited :signaled))
+           (with-active-processes-lock ()
+             (setf *active-processes*
+                   (delete proc *active-processes*))))))))
+  #+win32
+  (let (exited)
+    (with-active-processes-lock ()
+      (setf *active-processes*
+            (delete-if (lambda (proc)
+                         (multiple-value-bind (ok code)
+                             (get-exit-code-process (process-pid proc))
+                           (when (and (plusp ok) (/= code 259))
+                             (setf (process-%status proc) :exited
+                                   (process-exit-code proc) code)
+                             (when (process-status-hook proc)
+                               (push proc exited))
+                             t)))
+                       *active-processes*)))
+    ;; Can't call the hooks before all the processes have been deal
+    ;; with, as calling a hook may cause re-entry to
+    ;; GET-PROCESS-STATUS-CHANGES. That may be OK when using wait3,
+    ;; but in the Windows implementation is would be deeply bad.
+    (dolist (proc exited)
+      (let ((hook (process-status-hook proc)))
+        (when hook
+          (funcall hook proc))))))

 \f
 ;;;; RUN-PROGRAM and close friends
 
 \f
 ;;;; RUN-PROGRAM and close friends
 

@@ -364,25 +390,52 @@ The function is called with PROCESS as its only argument.")
 ;;; the master side of the pty, the file descriptor for the slave side
 ;;; of the pty, and the name of the tty device for the slave side.
 #-win32
 ;;; the master side of the pty, the file descriptor for the slave side
 ;;; of the pty, and the name of the tty device for the slave side.
 #-win32

-(defun find-a-pty ()
-  (dolist (char '(#\p #\q))
-    (dotimes (digit 16)
-      (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit) 'base-string))
-             (master-fd (sb-unix:unix-open master-name
-                                           sb-unix:o_rdwr
-                                           #o666)))
-        (when master-fd
-          (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit) 'base-string))
-                 (slave-fd (sb-unix:unix-open slave-name
-                                              sb-unix:o_rdwr
-                                              #o666)))
-            (when slave-fd
-              (return-from find-a-pty
-                (values master-fd
-                        slave-fd
-                        slave-name)))
-            (sb-unix:unix-close master-fd))))))
-  (error "could not find a pty"))
+(progn
+  (define-alien-routine ptsname c-string (fd int))
+  (define-alien-routine grantpt boolean (fd int))
+  (define-alien-routine unlockpt boolean (fd int))
+
+  (defun find-a-pty ()
+    ;; First try to use the Unix98 pty api.
+    (let* ((master-name (coerce (format nil "/dev/ptmx") 'base-string))
+           (master-fd (sb-unix:unix-open master-name
+                                         sb-unix:o_rdwr
+                                         #o666)))
+      (when master-fd
+        (grantpt master-fd)
+        (unlockpt master-fd)
+        (let* ((slave-name (ptsname master-fd))
+               (slave-fd (sb-unix:unix-open slave-name
+                                            sb-unix:o_rdwr
+                                            #o666)))
+          (when slave-fd
+            (return-from find-a-pty
+              (values master-fd
+                      slave-fd
+                      slave-name)))
+          (sb-unix:unix-close master-fd))
+        (error "could not find a pty")))
+    ;; No dice, try using the old-school method.
+    (dolist (char '(#\p #\q))
+      (dotimes (digit 16)
+        (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit)
+                                    'base-string))
+               (master-fd (sb-unix:unix-open master-name
+                                             sb-unix:o_rdwr
+                                             #o666)))
+          (when master-fd
+            (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit)
+                                       'base-string))
+                   (slave-fd (sb-unix:unix-open slave-name
+                                                sb-unix:o_rdwr
+                                                #o666)))
+              (when slave-fd
+                (return-from find-a-pty
+                  (values master-fd
+                          slave-fd
+                          slave-name)))
+              (sb-unix:unix-close master-fd))))))
+    (error "could not find a pty")))

 
 #-win32
 (defun open-pty (pty cookie)
 
 #-win32
 (defun open-pty (pty cookie)

@@ -404,7 +457,9 @@ The function is called with PROCESS as its only argument.")
                                      :dual-channel-p t)))))
 
 (defmacro round-bytes-to-words (n)
                                      :dual-channel-p t)))))
 
 (defmacro round-bytes-to-words (n)

-  `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
+  (let ((bytes-per-word (/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)))
+    `(logandc2 (the fixnum (+ (the fixnum ,n)
+                              (1- ,bytes-per-word))) (1- ,bytes-per-word))))

 
 (defun string-list-to-c-strvec (string-list)
   ;; Make a pass over STRING-LIST to calculate the amount of memory
 
 (defun string-list-to-c-strvec (string-list)
   ;; Make a pass over STRING-LIST to calculate the amount of memory

@@ -412,7 +467,7 @@ The function is called with PROCESS as its only argument.")
   (let ((string-bytes 0)
         ;; We need an extra for the null, and an extra 'cause exect
         ;; clobbers argv[-1].
   (let ((string-bytes 0)
         ;; We need an extra for the null, and an extra 'cause exect
         ;; clobbers argv[-1].

-        (vec-bytes (* #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)
+        (vec-bytes (* #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)

                       (+ (length string-list) 2))))
     (declare (fixnum string-bytes vec-bytes))
     (dolist (s string-list)
                       (+ (length string-list) 2))))
     (declare (fixnum string-bytes vec-bytes))
     (dolist (s string-list)

@@ -422,7 +477,7 @@ The function is called with PROCESS as its only argument.")
     (let* ((total-bytes (+ string-bytes vec-bytes))
            (vec-sap (sb-sys:allocate-system-memory total-bytes))
            (string-sap (sap+ vec-sap vec-bytes))
     (let* ((total-bytes (+ string-bytes vec-bytes))
            (vec-sap (sb-sys:allocate-system-memory total-bytes))
            (string-sap (sap+ vec-sap vec-bytes))

-           (i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)))
+           (i #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)))

       (declare (type (and unsigned-byte fixnum) total-bytes i)
                (type sb-sys:system-area-pointer vec-sap string-sap))
       (dolist (s string-list)
       (declare (type (and unsigned-byte fixnum) total-bytes i)
                (type sb-sys:system-area-pointer vec-sap string-sap))
       (dolist (s string-list)

@@ -438,11 +493,11 @@ The function is called with PROCESS as its only argument.")
           ;; Blast the pointer to the string into place.
           (setf (sap-ref-sap vec-sap i) string-sap)
           (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
           ;; Blast the pointer to the string into place.
           (setf (sap-ref-sap vec-sap i) string-sap)
           (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))

-          (incf i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits))))
+          (incf i #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits))))

       ;; Blast in the last null pointer.
       (setf (sap-ref-sap vec-sap i) (int-sap 0))
       ;; Blast in the last null pointer.
       (setf (sap-ref-sap vec-sap i) (int-sap 0))

-      (values vec-sap (sap+ vec-sap #.(/ sb-vm::n-machine-word-bits
-                                         sb-vm::n-byte-bits))
+      (values vec-sap (sap+ vec-sap #.(/ sb-vm:n-machine-word-bits
+                                         sb-vm:n-byte-bits))

               total-bytes))))
 
 (defmacro with-c-strvec ((var str-list) &body body)
               total-bytes))))
 
 (defmacro with-c-strvec ((var str-list) &body body)

@@ -476,7 +531,7 @@ The function is called with PROCESS as its only argument.")
 
 ;;; Is UNIX-FILENAME the name of a file that we can execute?
 (defun unix-filename-is-executable-p (unix-filename)
 
 ;;; Is UNIX-FILENAME the name of a file that we can execute?
 (defun unix-filename-is-executable-p (unix-filename)

-  (let ((filename (coerce unix-filename 'base-string)))
+  (let ((filename (coerce unix-filename 'string)))

     (values (and (eq (sb-unix:unix-file-kind filename) :file)
                  #-win32
                  (sb-unix:unix-access filename sb-unix:x_ok)))))
     (values (and (eq (sb-unix:unix-file-kind filename) :file)
                  #-win32
                  (sb-unix:unix-access filename sb-unix:x_ok)))))

@@ -731,7 +786,7 @@ argument. ARGS are the standard arguments that can be passed to a
 program. For no arguments, use NIL (which means that just the name of
 the program is passed as arg 0).
 
 program. For no arguments, use NIL (which means that just the name of
 the program is passed as arg 0).
 

-RUN-PROGRAM will either return a PROCESS structure. See the CMU
+RUN-PROGRAM will return a PROCESS structure. See the CMU

 Common Lisp Users Manual for details about the PROCESS structure.
 
    The &KEY arguments have the following meanings:
 Common Lisp Users Manual for details about the PROCESS structure.
 
    The &KEY arguments have the following meanings:

@@ -744,7 +799,7 @@ Common Lisp Users Manual for details about the PROCESS structure.
         NIL, continue running Lisp until the program finishes.
      :INPUT
         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
         NIL, continue running Lisp until the program finishes.
      :INPUT
         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard

-        input for the current process is inherited.  If NIL, /dev/null
+        input for the current process is inherited.  If NIL, nul

         is used.  If a pathname, the file so specified is used.  If a stream,
         all the input is read from that stream and send to the subprocess.  If
         :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
         is used.  If a pathname, the file so specified is used.  If a stream,
         all the input is read from that stream and send to the subprocess.  If
         :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends

@@ -756,7 +811,7 @@ Common Lisp Users Manual for details about the PROCESS structure.
            NIL (the default) to return NIL from RUN-PROGRAM
      :OUTPUT
         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
            NIL (the default) to return NIL from RUN-PROGRAM
      :OUTPUT
         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard

-        output for the current process is inherited.  If NIL, /dev/null
+        output for the current process is inherited.  If NIL, nul

         is used.  If a pathname, the file so specified is used.  If a stream,
         all the output from the process is written to this stream. If
         :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
         is used.  If a pathname, the file so specified is used.  If a stream,
         all the output from the process is written to this stream. If
         :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can

@@ -784,7 +839,17 @@ Common Lisp Users Manual for details about the PROCESS structure.
         proc
         ;; It's friendly to allow the caller to pass any string
         ;; designator, but internally we'd like SIMPLE-STRINGs.
         proc
         ;; It's friendly to allow the caller to pass any string
         ;; designator, but internally we'd like SIMPLE-STRINGs.

-        (simple-args (mapcar (lambda (x) (coerce x 'simple-string)) args)))
+        (simple-args
+          (mapcar
+            (lambda (x)
+              (coerce
+                ;; Apparently any spaces or double quotes in the arguments
+                ;; need to be escaped on win32.
+                (if (position-if (lambda (c) (find c '(#\" #\Space))) x)
+                    (write-to-string x)
+                    x)
+                'simple-string))
+            args)))

     (unwind-protect
          (let ((pfile
                 (if search
     (unwind-protect
          (let ((pfile
                 (if search

@@ -814,11 +879,17 @@ Common Lisp Users Manual for details about the PROCESS structure.
                                          (spawn pfile args-vec
                                                 stdin stdout stderr
                                                 (if wait 1 0)))))
                                          (spawn pfile args-vec
                                                 stdin stdout stderr
                                                 (if wait 1 0)))))

-                            (when (< handle 0)
+                            (when (= handle -1)

                               (error "Couldn't spawn program: ~A" (strerror)))
                             (setf proc
                                   (if wait
                               (error "Couldn't spawn program: ~A" (strerror)))
                             (setf proc
                                   (if wait

-                                      (make-process :%status :exited
+                                      (make-process :pid handle
+                                                    :%status :exited
+                                                    :input input-stream
+                                                    :output output-stream
+                                                    :error error-stream
+                                                    :status-hook status-hook
+                                                    :cookie cookie

                                                     :exit-code handle)
                                       (make-process :pid handle
                                                     :%status :running
                                                     :exit-code handle)
                                       (make-process :pid handle
                                                     :%status :running

@@ -826,7 +897,14 @@ Common Lisp Users Manual for details about the PROCESS structure.
                                                     :output output-stream
                                                     :error error-stream
                                                     :status-hook status-hook
                                                     :output output-stream
                                                     :error error-stream
                                                     :status-hook status-hook

-                                                    :cookie cookie))))))))))
+                                                    :cookie cookie)))
+                            (push proc *active-processes*)))))))
+      (dolist (fd *close-in-parent*)
+        (sb-unix:unix-close fd)))
+    (unless proc
+      (dolist (fd *close-on-error*)
+        (sb-unix:unix-close fd)))
+

     proc))
 
 ;;; Install a handler for any input that shows up on the file
     proc))
 
 ;;; Install a handler for any input that shows up on the file

@@ -888,6 +966,19 @@ Common Lisp Users Manual for details about the PROCESS structure.
                                 (write-string string stream
                                               :end count)))))))))))
 
                                 (write-string string stream
                                               :end count)))))))))))
 

+(defun get-stream-fd (stream direction)
+  (typecase stream
+    (sb-sys:fd-stream
+     (values (sb-sys:fd-stream-fd stream) nil))
+    (synonym-stream
+     (get-stream-fd (symbol-value (synonym-stream-symbol stream)) direction))
+    (two-way-stream
+     (ecase direction
+       (:input
+        (get-stream-fd (two-way-stream-input-stream stream) direction))
+       (:output
+        (get-stream-fd (two-way-stream-output-stream stream) direction))))))
+

 ;;; Find a file descriptor to use for object given the direction.
 ;;; Returns the descriptor. If object is :STREAM, returns the created
 ;;; stream as the second value.
 ;;; Find a file descriptor to use for object given the direction.
 ;;; Returns the descriptor. If object is :STREAM, returns the created
 ;;; stream as the second value.

@@ -911,7 +1002,8 @@ Common Lisp Users Manual for details about the PROCESS structure.
                                   (t sb-unix:o_rdwr))
                                 #o666)
            (unless fd
                                   (t sb-unix:o_rdwr))
                                 #o666)
            (unless fd

-             (error "~@<couldn't open \"/dev/null\": ~2I~_~A~:>"
+             (error #-win32 "~@<couldn't open \"/dev/null\": ~2I~_~A~:>"
+                    #+win32 "~@<couldn't open \"nul\" device: ~2I~_~A~:>"

                     (strerror errno)))
            (push fd *close-in-parent*)
            (values fd nil)))
                     (strerror errno)))
            (push fd *close-in-parent*)
            (values fd nil)))

@@ -948,56 +1040,56 @@ Common Lisp Users Manual for details about the PROCESS structure.
                    (t
                     (error "couldn't duplicate file descriptor: ~A"
                            (strerror errno)))))))
                    (t
                     (error "couldn't duplicate file descriptor: ~A"
                            (strerror errno)))))))

-        ((sb-sys:fd-stream-p object)
-         (values (sb-sys:fd-stream-fd object) nil))

         ((streamp object)
          (ecase direction
            (:input
         ((streamp object)
          (ecase direction
            (:input

-            ;; FIXME: We could use a better way of setting up
-            ;; temporary files, both here and in LOAD-FOREIGN.
-            (dotimes (count
-                       256
-                      (error "could not open a temporary file in /tmp"))
-              (let* ((name (coerce (format nil "/tmp/.run-program-~D" count)
-                                   'base-string))
-                     (fd (sb-unix:unix-open name
-                                            (logior sb-unix:o_rdwr
-                                                    sb-unix:o_creat
-                                                    sb-unix:o_excl)
-                                            #o666)))
-                (sb-unix:unix-unlink name)
-                (when fd
-                  (let ((newline (string #\Newline)))
-                    (loop
-                        (multiple-value-bind
-                              (line no-cr)
-                            (read-line object nil nil)
-                          (unless line
-                            (return))
-                          (sb-unix:unix-write
-                           fd
-                           ;; FIXME: this really should be
-                           ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...).
-                           ;; RUN-PROGRAM should take an
-                           ;; external-format argument, which should
-                           ;; be passed down to here.  Something
-                           ;; similar should happen on :OUTPUT, too.
-                           (map '(vector (unsigned-byte 8)) #'char-code line)
-                           0 (length line))
-                          (if no-cr
-                              (return)
-                              (sb-unix:unix-write fd newline 0 1)))))
-                  (sb-unix:unix-lseek fd 0 sb-unix:l_set)
-                  (push fd *close-in-parent*)
-                  (return (values fd nil))))))
+            (or (get-stream-fd object :input)
+                ;; FIXME: We could use a better way of setting up
+                ;; temporary files
+                (dotimes (count
+                           256
+                          (error "could not open a temporary file in /tmp"))
+                  (let* ((name (coerce (format nil "/tmp/.run-program-~D" count)
+                                       'base-string))
+                         (fd (sb-unix:unix-open name
+                                                (logior sb-unix:o_rdwr
+                                                        sb-unix:o_creat
+                                                        sb-unix:o_excl)
+                                                #o666)))
+                    (sb-unix:unix-unlink name)
+                    (when fd
+                      (let ((newline (string #\Newline)))
+                        (loop
+                           (multiple-value-bind
+                                 (line no-cr)
+                               (read-line object nil nil)
+                             (unless line
+                               (return))
+                             (sb-unix:unix-write
+                              fd
+                              ;; FIXME: this really should be
+                              ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...).
+                              ;; RUN-PROGRAM should take an
+                              ;; external-format argument, which should
+                              ;; be passed down to here.  Something
+                              ;; similar should happen on :OUTPUT, too.
+                              (map '(vector (unsigned-byte 8)) #'char-code line)
+                              0 (length line))
+                             (if no-cr
+                                 (return)
+                                 (sb-unix:unix-write fd newline 0 1)))))
+                      (sb-unix:unix-lseek fd 0 sb-unix:l_set)
+                      (push fd *close-in-parent*)
+                      (return (values fd nil)))))))

            (:output
            (:output

-            (multiple-value-bind (read-fd write-fd)
-                (sb-unix:unix-pipe)
-              (unless read-fd
-                (error "couldn't create pipe: ~S" (strerror write-fd)))
-              (copy-descriptor-to-stream read-fd object cookie)
-              (push read-fd *close-on-error*)
-              (push write-fd *close-in-parent*)
-              (values write-fd nil)))))
+            (or (get-stream-fd object :output)
+                (multiple-value-bind (read-fd write-fd)
+                    (sb-unix:unix-pipe)
+                  (unless read-fd
+                    (error "couldn't create pipe: ~S" (strerror write-fd)))
+                  (copy-descriptor-to-stream read-fd object cookie)
+                  (push read-fd *close-on-error*)
+                  (push write-fd *close-in-parent*)
+                  (values write-fd nil))))))

         (t
          (error "invalid option to RUN-PROGRAM: ~S" object))))
         (t
          (error "invalid option to RUN-PROGRAM: ~S" object))))