X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=25c31c20aeb4602ad49810080ae429af1bcdb0e8;hb=fd00d78accb69be3a626a29120ba17a18569b98c;hp=946f95e98cebaa5304b081b4e2ae5d39ee496ecc;hpb=670010e3f3dcd62efaf23f61abdc73950edb88c6;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 946f95e..25c31c2 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -63,7 +63,7 @@ (defun unix-environment-cmucl-from-sbcl (sbcl) (mapcan (lambda (string) - (declare (type simple-string string)) + (declare (type simple-base-string string)) (let ((=-pos (position #\= string :test #'equal))) (if =-pos (list @@ -86,8 +86,8 @@ (mapcar (lambda (cons) (destructuring-bind (key . val) cons - (declare (type keyword key) (type simple-string val)) - (concatenate 'simple-string (symbol-name key) "=" val))) + (declare (type keyword key) (type simple-base-string val)) + (concatenate 'simple-base-string (symbol-name key) "=" val))) cmucl)) ;;;; Import wait3(2) from Unix. @@ -124,10 +124,10 @@ (values pid (if (position signal #.(vector - (sb-unix:unix-signal-number :sigstop) - (sb-unix:unix-signal-number :sigtstp) - (sb-unix:unix-signal-number :sigttin) - (sb-unix:unix-signal-number :sigttou))) + sb-unix:sigstop + sb-unix:sigtstp + sb-unix:sigttin + sb-unix:sigttou)) :stopped :signaled) signal @@ -212,7 +212,7 @@ (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) sb-unix:TIOCSIGSEND (sb-sys:int-sap - (sb-unix:unix-signal-number signal)))) + signal))) ((:process-group #-hpux :pty-process-group) (sb-unix:unix-killpg pid signal)) (t @@ -220,8 +220,7 @@ (cond ((not okay) (values nil errno)) ((and (eql pid (process-pid proc)) - (= (sb-unix:unix-signal-number signal) - (sb-unix:unix-signal-number :sigcont))) + (= signal sb-unix:sigcont)) (setf (process-%status proc) :running) (setf (process-exit-code proc) nil) (when (process-status-hook proc) @@ -290,12 +289,12 @@ (defun find-a-pty () (dolist (char '(#\p #\q)) (dotimes (digit 16) - (let* ((master-name (format nil "/dev/pty~C~X" char digit)) + (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 (format nil "/dev/tty~C~X" char digit)) + (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))) @@ -332,7 +331,8 @@ (let ((string-bytes 0) ;; We need an extra for the null, and an extra 'cause exect ;; clobbers argv[-1]. - (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2)))) + (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) (enforce-type s simple-string) @@ -341,25 +341,28 @@ (let* ((total-bytes (+ string-bytes vec-bytes)) (vec-sap (sb-sys:allocate-system-memory total-bytes)) (string-sap (sap+ vec-sap vec-bytes)) - (i #-alpha 4 #+alpha 8)) + (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 (simple-string s)) (let ((n (length s))) ;; Blast the string into place. - (sb-kernel:copy-to-system-area (the simple-string s) - (* sb-vm:vector-data-offset - sb-vm:n-word-bits) - string-sap 0 - (* (1+ n) sb-vm:n-byte-bits)) + (sb-kernel:copy-ub8-to-system-area (the simple-base-string + ;; FIXME + (coerce s 'simple-base-string)) + 0 + string-sap 0 + (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 #-alpha 4 #+alpha 8))) + (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 #-alpha 4 #+alpha 8) total-bytes)))) + (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) (with-unique-names (sap size) @@ -381,12 +384,28 @@ (stderr sb-alien:int)) ;;; Is UNIX-FILENAME the name of a file that we can execute? -;;; XXX does this actually work for symlinks? (defun unix-filename-is-executable-p (unix-filename) (declare (type simple-string unix-filename)) + (setf unix-filename (coerce unix-filename 'base-string)) (values (and (eq (sb-unix:unix-file-kind unix-filename) :file) (sb-unix:unix-access unix-filename sb-unix:x_ok)))) +(defun find-executable-in-search-path (pathname + &optional + (search-path (posix-getenv "PATH"))) + "Find the first executable file matching PATHNAME in any of the colon-separated list of pathnames SEARCH-PATH" + (loop for end = (position #\: search-path :start (if end (1+ end) 0)) + and start = 0 then (and end (1+ end)) + while start + ;; the truename of a file naming a directory is the + ;; directory, at least until pfdietz comes along and says why + ;; that's noncompliant -- CSR, c. 2003-08-10 + for truename = (probe-file (subseq search-path start end)) + for fullpath = (when truename (merge-pathnames pathname truename)) + when (and fullpath + (unix-filename-is-executable-p (namestring fullpath))) + return fullpath)) + ;;; FIXME: There shouldn't be two semiredundant versions of the ;;; documentation. Since this is a public extension function, the ;;; documentation should be in the doc string. So all information from @@ -438,6 +457,7 @@ (posix-environ)) environment-p) (wait t) + search pty input if-input-does-not-exist @@ -467,12 +487,16 @@ The &KEY arguments have the following meanings: :ENVIRONMENT - a list of SIMPLE-STRINGs describing the new Unix environment (as - in \"man environ\"). The default is to copy the environment of + a list of SIMPLE-BASE-STRINGs describing the new Unix environment + (as in \"man environ\"). The default is to copy the environment of the current process. :ENV an alternative lossy representation of the new Unix environment, for compatibility with CMU CL + :SEARCH + Look for PROGRAM in each of the directories along the $PATH + environment variable. Otherwise an absolute pathname is required. + (See also FIND-EXECUTABLE-IN-SEARCH-PATH) :WAIT If non-NIL (default), wait until the created process finishes. If NIL, continue running Lisp until the program finishes. @@ -517,7 +541,7 @@ (when (and env-p environment-p) (error "can't specify :ENV and :ENVIRONMENT simultaneously")) ;; Make sure that the interrupt handler is installed. - (sb-sys:enable-interrupt :sigchld #'sigchld-handler) + (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler) ;; Prepend the program to the argument list. (push (namestring program) args) (let (;; Clear various specials used by GET-DESCRIPTOR-FOR to @@ -531,17 +555,11 @@ ;; designator, but internally we'd like SIMPLE-STRINGs. (simple-args (mapcar (lambda (x) (coerce x 'simple-string)) args))) (unwind-protect - (let (;; FIXME: The old code here used to do - ;; (MERGE-PATHNAMES PROGRAM "path:"), - ;; which is the right idea (searching through the Unix - ;; PATH). Unfortunately, there is no logical pathname - ;; "path:" defined in sbcl-0.6.10. It would probably be - ;; reasonable to restore Unix PATH searching in SBCL, e.g. - ;; with a function FIND-EXECUTABLE-FILE-IN-POSIX-PATH. - ;; CMU CL did it with a "PATH:" search list, but CMU CL - ;; search lists are a non-ANSI extension that SBCL - ;; doesn't support. -- WHN) - (pfile (unix-namestring program t)) + (let ((pfile + (if search + (let ((p (find-executable-in-search-path program))) + (and p (unix-namestring p t))) + (unix-namestring program t))) (cookie (list 0))) (unless pfile (error "no such program: ~S" program)) @@ -601,7 +619,7 @@ ;;; stream. (defun copy-descriptor-to-stream (descriptor stream cookie) (incf (car cookie)) - (let ((string (make-string 256)) + (let ((string (make-string 256 :element-type 'base-char)) handler) (setf handler (sb-sys:add-fd-handler @@ -647,11 +665,10 @@ ~2I~_~A~:>" (strerror errno))) (t - (sb-kernel:copy-from-system-area + (sb-kernel:copy-ub8-from-system-area (alien-sap buf) 0 - string (* sb-vm:vector-data-offset - sb-vm:n-word-bits) - (* count sb-vm:n-byte-bits)) + string 0 + count) (write-string string stream :end count))))))))))) @@ -670,7 +687,7 @@ ;; Use /dev/null. (multiple-value-bind (fd errno) - (sb-unix:unix-open "/dev/null" + (sb-unix:unix-open #.(coerce "/dev/null" 'base-string) (case direction (:input sb-unix:o_rdonly) (:output sb-unix:o_wronly) @@ -722,7 +739,7 @@ (dotimes (count 256 (error "could not open a temporary file in /tmp")) - (let* ((name (format nil "/tmp/.run-program-~D" count)) + (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 @@ -737,7 +754,16 @@ (read-line object nil nil) (unless line (return)) - (sb-unix:unix-write fd line 0 (length line)) + (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)))))