X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=5c4f9fc229ce023d87850aa1c5033fffc7849cb7;hb=4603ca100a7d181fe4316429365fc725501336dd;hp=cb6c489033f8f1a754eaecc863895dd0ccb21799;hpb=7275aafca8c682f874161d92aa07662a53f056b7;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index cb6c489..5c4f9fc 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -154,9 +154,7 @@ ;;; accesses it, that's why we need without-interrupts. (defmacro with-active-processes-lock (() &body body) #-win32 - `(without-interrupts - (sb-thread:with-mutex (*active-processes-lock*) - ,@body)) + `(sb-thread::call-with-system-mutex (lambda () ,@body) *active-processes-lock*) #+win32 `(progn ,@body)) @@ -392,25 +390,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 -(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) @@ -432,7 +457,9 @@ status slot." :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 @@ -440,7 +467,7 @@ status slot." (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) @@ -450,7 +477,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)) - (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) @@ -466,11 +493,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)))) - (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)) - (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) @@ -504,7 +531,7 @@ status slot." ;;; 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))))) @@ -812,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. - (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 @@ -842,7 +879,7 @@ Common Lisp Users Manual for details about the PROCESS structure. (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