1.0.4.90: revert 1.0.4.89 changes to ROOM

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

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index 5b6c87c..ea4fe4c 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -157,6 +157,7 @@
   `(without-interrupts
     (sb-thread:with-mutex (*active-processes-lock*)
       ,@body))
   `(without-interrupts
     (sb-thread:with-mutex (*active-processes-lock*)
       ,@body))

+  #+win32

   `(progn ,@body))
 
 (defstruct (process (:copier nil))
   `(progn ,@body))
 
 (defstruct (process (:copier nil))

@@ -391,25 +392,52 @@ status slot."
 ;;; 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)

@@ -431,7 +459,9 @@ status slot."
                                      :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

@@ -439,7 +469,7 @@ status slot."
   (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)

@@ -449,7 +479,7 @@ status slot."
     (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)

@@ -465,11 +495,11 @@ status slot."
           ;; 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)

@@ -503,7 +533,7 @@ status slot."
 
 ;;; 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)))))

@@ -758,7 +788,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:

@@ -771,7 +801,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

@@ -783,7 +813,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

@@ -811,7 +841,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

@@ -841,11 +881,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

@@ -853,13 +899,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))))))))))
-    ;; FIXME: this should probably use PROCESS-WAIT instead instead
-    ;; of special argument to SPAWN.
-    (unless wait
-      (push proc *active-processes*))
-    (when (and wait status-hook)
-      (funcall status-hook proc))
+                                                    :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

@@ -921,6 +968,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.

@@ -944,7 +1004,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)))

@@ -981,56 +1042,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))))