1.0.18.16: many STYLE-WARNING changes.

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

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index e1ab659..d223e77 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -154,7 +154,8 @@
 ;;; accesses it, that's why we need without-interrupts.
 (defmacro with-active-processes-lock (() &body body)
   #-win32
-  `(sb-thread::call-with-system-mutex (lambda () ,@body) *active-processes-lock*)
+  `(sb-thread::with-system-mutex (*active-processes-lock* :allow-with-interrupts t)
+     ,@body)
   #+win32
   `(progn ,@body))
 
@@ -390,7 +391,7 @@ status slot."
 ;;; Find an unused pty. Return three values: the file descriptor for
 ;;; 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
+#-(or win32 openbsd)
 (progn
   (define-alien-routine ptsname c-string (fd int))
   (define-alien-routine grantpt boolean (fd int))
@@ -437,6 +438,21 @@ status slot."
                           slave-name)))
               (sb-unix:unix-close master-fd))))))
     (error "could not find a pty")))
+#+openbsd
+(progn
+  (define-alien-routine openpty int (amaster int :out) (aslave int :out)
+                        (name (* char)) (termp (* t)) (winp (* t)))
+  (defun find-a-pty ()
+    (with-alien ((name-buf (array char 16)))
+      (multiple-value-bind (return-val master-fd slave-fd)
+          (openpty (cast name-buf (* char)) nil nil)
+        (if (zerop return-val)
+            (values master-fd
+                    slave-fd
+                    (sb-alien::c-string-to-string (alien-sap name-buf)
+                                                  (sb-impl::default-external-format)
+                                                  'character))
+            (error "could not find a pty"))))))
 
 #-win32
 (defun open-pty (pty cookie)
@@ -489,7 +505,7 @@ status slot."
         ;; Put the pointer in the vector.
         (setf (sap-ref-sap vec-sap vec-index-offset) string-sap)
         ;; Advance string-sap for the next string.
-        (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ size))))
+        (setf string-sap (sap+ string-sap (round-bytes-to-words size)))
         (incf vec-index-offset bytes-per-word)))
     ;; Final null pointer.
     (setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0))
@@ -815,9 +831,11 @@ Users Manual for details about the PROCESS structure."#-win32"
                                          (ash 1 descriptor)
                                          0 0 0)
                   (cond ((null result)
-                         (error "~@<couldn't select on sub-process: ~
-                                           ~2I~_~A~:>"
-                                (strerror readable/errno)))
+                         (if (eql sb-unix:eintr readable/errno)
+                             (return)
+                             (error "~@<Couldn't select on sub-process: ~
+                                        ~2I~_~A~:>"
+                                    (strerror readable/errno))))
                         ((zerop result)
                          (return))))
                 (multiple-value-bind (count errno)
@@ -906,14 +924,10 @@ Users Manual for details about the PROCESS structure."#-win32"
   ;; run afoul of disk quotas or to choke on small /tmp file systems.
   (flet ((make-temp-fd ()
            (multiple-value-bind (fd name/errno)
-               (sb-unix:unix-mkstemp "/tmp/.run-program-XXXXXX")
+               (sb-unix:sb-mkstemp "/tmp/.run-program-XXXXXX" #o0600)
              (unless fd
                (error "could not open a temporary file: ~A"
                       (strerror name/errno)))
-             #-win32 #|FIXME: should say (logior s_irusr s_iwusr)|#
-             (unless (sb-unix:unix-chmod name/errno #o600)
-               (sb-unix:unix-close fd)
-               (error "failed to chmod the temporary file?!"))
              (unless (sb-unix:unix-unlink name/errno)
                (sb-unix:unix-close fd)
                (error "failed to unlink ~A" name/errno))
@@ -965,7 +979,11 @@ Users Manual for details about the PROCESS structure."#-win32"
                 (error "Direction must be either :INPUT or :OUTPUT, not ~S."
                        direction)))))
           ((or (pathnamep object) (stringp object))
-           (with-open-stream (file (apply #'open object keys))
+           ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather
+           ;; than munge the &rest list for OPEN, just disable keyword
+           ;; validation there.
+           (with-open-stream (file (apply #'open object :allow-other-keys t
+                                          keys))
              (multiple-value-bind
                    (fd errno)
                  (sb-unix:unix-dup (sb-sys:fd-stream-fd file))