X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=b854e3109faf78fa1f20c52f79ff4d2f2877bb26;hb=0dda5090b6c16a641000b4eb2dcd479f39b784ca;hp=e85e2cc259360393a7536e5f5136a8ea5b782806;hpb=5b96a0e6ff6390f3c85f90a72207cf052ea11bf6;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index e85e2cc..b854e31 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -455,13 +455,19 @@ status slot." (copy-descriptor-to-stream new-fd pty cookie external-format))) (values name (sb-sys:make-fd-stream master :input t :output t + :external-format external-format :element-type :default :dual-channel-p t))))) -(defmacro round-bytes-to-words (n) +;; Null terminate strings only C-side: otherwise we can run into +;; A-T-S-L even for simple encodings like ASCII. Multibyte encodings +;; may need more than a single byte of zeros; assume 4 byte is enough +;; for everyone. +(defmacro round-null-terminated-bytes-to-words (n) (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)))) + `(logandc2 (the sb-vm:signed-word (+ (the fixnum ,n) + 4 (1- ,bytes-per-word))) + (1- ,bytes-per-word)))) (defun string-list-to-c-strvec (string-list) (let* ((bytes-per-word (/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)) @@ -469,28 +475,33 @@ status slot." ;; clobbers argv[-1]. (vec-bytes (* bytes-per-word (+ (length string-list) 2))) (octet-vector-list (mapcar (lambda (s) - (string-to-octets s :null-terminate t)) + (string-to-octets s)) string-list)) (string-bytes (reduce #'+ octet-vector-list :key (lambda (s) - (round-bytes-to-words (length s))))) + (round-null-terminated-bytes-to-words + (length s))))) (total-bytes (+ string-bytes vec-bytes)) ;; Memory to hold the vector of pointers and all the strings. (vec-sap (sb-sys:allocate-system-memory total-bytes)) (string-sap (sap+ vec-sap vec-bytes)) ;; Index starts from [1]! (vec-index-offset bytes-per-word)) - (declare (index string-bytes vec-bytes total-bytes) + (declare (sb-vm:signed-word vec-bytes) + (sb-vm:word string-bytes total-bytes) (sb-sys:system-area-pointer vec-sap string-sap)) (dolist (octets octet-vector-list) (declare (type (simple-array (unsigned-byte 8) (*)) octets)) (let ((size (length octets))) ;; Copy string. (sb-kernel:copy-ub8-to-system-area octets 0 string-sap 0 size) + ;; NULL-terminate it + (sb-kernel:system-area-ub8-fill 0 string-sap size 4) ;; 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 size))) + (setf string-sap (sap+ string-sap + (round-null-terminated-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)) @@ -724,7 +735,7 @@ Users Manual for details about the PROCESS structure."#-win32" #+win32 `(declare (ignore ,pty ,cookie)) #+win32 `(let (,pty-name ,pty-stream) ,@body) #-win32 `(multiple-value-bind (,pty-name ,pty-stream) - (open-pty ,pty ,cookie) + (open-pty ,pty ,cookie :external-format external-format) ,@body)) (with-args-vec ((vec args) &body body) `(with-c-strvec (,vec ,args) @@ -762,7 +773,7 @@ Users Manual for details about the PROCESS structure."#-win32" (if search 1 0) environment-vec pty-name (if wait 1 0)))) - (unless (= child -1) + (unless (minusp child) (setf proc (apply #'make-process @@ -780,21 +791,29 @@ Users Manual for details about the PROCESS structure."#-win32" (list :%status :running)))) (push proc *active-processes*))))) ;; Report the error outside the lock. - (when (= child -1) - (error "couldn't fork child process: ~A" - (strerror))))))))) + #+win32 + (when (minusp child) + (error "Couldn't execute ~S: ~A" progname (strerror))) + #-win32 + (case child + (-2 + (error "Couldn't execute ~S: ~A" progname (strerror))) + (-1 + (error "Couldn't fork child process: ~A" (strerror)))))))))) (dolist (fd *close-in-parent*) (sb-unix:unix-close fd)) (unless proc (dolist (fd *close-on-error*) (sb-unix:unix-close fd)) - ;; FIXME: nothing seems to set this. #-win32 (dolist (handler *handlers-installed*) - (sb-sys:remove-fd-handler handler)))) - #-win32 - (when (and wait proc) - (process-wait proc)) + (sb-sys:remove-fd-handler handler))) + #-win32 + (when (and wait proc) + (unwind-protect + (process-wait proc) + (dolist (handler *handlers-installed*) + (sb-sys:remove-fd-handler handler))))) proc))) ;;; Install a handler for any input that shows up on the file @@ -885,7 +904,9 @@ Users Manual for details about the PROCESS structure."#-win32" (strerror errno))) (t (incf read-end count) - (funcall copy-fun)))))))))) + (funcall copy-fun)))))))) + #-win32 + (push handler *handlers-installed*))) ;;; FIXME: something very like this is done in SB-POSIX to treat ;;; streams as file descriptor designators; maybe we can combine these @@ -938,7 +959,9 @@ Users Manual for details about the PROCESS structure."#-win32" (cond ((eq object t) ;; No new descriptor is needed. (values -1 nil)) - ((eq object nil) + ((or (eq object nil) + (and (typep object 'broadcast-stream) + (not (broadcast-stream-streams object)))) ;; Use /dev/null. (multiple-value-bind (fd errno) @@ -1051,7 +1074,10 @@ Users Manual for details about the PROCESS structure."#-win32" (loop with buf = (make-array 256 :element-type '(unsigned-byte 8)) for p = (read-sequence buf object) until (zerop p) - do (sb-unix:unix-write fd buf 0 p)))) + do (sb-unix:unix-write fd buf 0 p))) + (t + (error "Don't know how to copy from stream of element-type ~S" + et))) (sb-unix:unix-lseek fd 0 sb-unix:l_set) (push fd *close-in-parent*) (return (values fd nil)))))