X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=0808fdde7728d4aa710d5912565c240a1eae9846;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=95ebb73f37673b764525be7abe0211cfd966ddec;hpb=65f551e30f6f52855fdb7ff28e0cfff2f17c3e48;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 95ebb73..0808fdd 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,14 +341,16 @@ (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-kernel:copy-to-system-area (the simple-base-string + ;; FIXME + (coerce s 'simple-base-string)) (* sb-vm:vector-data-offset sb-vm:n-word-bits) string-sap 0 @@ -356,10 +358,12 @@ ;; 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) @@ -383,6 +387,7 @@ ;;; Is UNIX-FILENAME the name of a file that we can execute? (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)))) @@ -395,11 +400,11 @@ 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 - for fullpath = (merge-pathnames - pathname (truename - (subseq search-path start end))) - when (unix-filename-is-executable-p (namestring fullpath)) + ;; 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 @@ -483,8 +488,8 @@ 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, @@ -537,7 +542,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 @@ -615,7 +620,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 @@ -684,7 +689,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) @@ -736,7 +741,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 @@ -751,7 +756,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)))))