X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=aee63b8bb13482512eb2cbd92b97a9e29ed106aa;hb=e38cf29945f9ff0cfbf614c0c216be60e2515175;hp=1dad7f90faf569f0551fbef5ff4cee95ce70176a;hpb=e48026257ea92807b2a5ee799476be198fc64dd6;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 1dad7f9..aee63b8 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -45,28 +45,12 @@ ;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not ;;;; visible at GENESIS time. -(def-alien-variable "environ" (* c-string)) -(push (lambda () - ;; We redo this here to protect ourselves from this scenario: - ;; * Build under one version of shared lib, save a core. - ;; * Load core under another version of shared lib. ("Now - ;; where was environ again?" SIGSEGV, etc.) - ;; Obviously it's a KLUDGE to do this hack for every alien - ;; variable, but as it happens, as of sbcl-0.7.0 this is the - ;; only alien variable used to implement SBCL, so it's not - ;; worth coming up with a general solution. (A general - ;; solution would be nice for users who want to have their - ;; alien code be preserved across a save/load cycle, but this - ;; problem with alien variables is only one of several - ;; problems which'd need to be solved before that can happen.) - (def-alien-variable "environ" (* c-string))) - *after-save-initializations*) - +(define-alien-routine wrapped-environ (* c-string)) (defun posix-environ () "Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs." - (c-strings->string-list environ)) + (c-strings->string-list (wrapped-environ))) -;;; Convert as best we can from a SBCL representation of a Unix +;;; Convert as best we can from an SBCL representation of a Unix ;;; environment to a CMU CL representation. ;;; ;;; * (UNIX-ENVIRONMENT-CMUCL-FROM-SBCL '("Bletch=fub" "Noggin" "YES=No!")) @@ -108,30 +92,26 @@ ;;;; Import wait3(2) from Unix. -(sb-alien:def-alien-routine ("wait3" c-wait3) sb-c-call:int - (status sb-c-call:int :out) - (options sb-c-call:int) - (rusage sb-c-call:int)) - -(defconstant wait-wnohang #-svr4 1 #+svr4 #o100) -(defconstant wait-wuntraced #-svr4 2 #+svr4 4) -(defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced) +(define-alien-routine ("wait3" c-wait3) sb-alien:int + (status sb-alien:int :out) + (options sb-alien:int) + (rusage sb-alien:int)) (defun wait3 (&optional do-not-hang check-for-stopped) "Return any available status information on child process. " (multiple-value-bind (pid status) (c-wait3 (logior (if do-not-hang - wait-wnohang + sb-unix:wnohang 0) (if check-for-stopped - wait-wuntraced + sb-unix:wuntraced 0)) 0) (cond ((or (minusp pid) (zerop pid)) nil) ((eql (ldb (byte 8 0) status) - wait-wstopped) + sb-unix:wstopped) (values pid :stopped (ldb (byte 8 8) status))) @@ -174,7 +154,7 @@ (defmethod print-object ((process process) stream) (print-unreadable-object (process stream :type t) (format stream - "~D ~S" + "~W ~S" (process-pid process) (process-status process))) process) @@ -202,12 +182,12 @@ #-hpux ;;; Find the current foreground process group id. (defun find-current-foreground-process (proc) - (sb-alien:with-alien ((result sb-c-call:int)) + (with-alien ((result sb-alien:int)) (multiple-value-bind (wonp error) (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) sb-unix:TIOCGPGRP - (sb-alien:alien-sap (sb-alien:addr result))) + (alien-sap (sb-alien:addr result))) (unless wonp (error "TIOCPGRP ioctl failed: ~S" (strerror error))) result)) @@ -305,19 +285,19 @@ (defvar *handlers-installed* nil) #+FreeBSD -(def-alien-type nil +(define-alien-type nil (struct sgttyb - (sg-ispeed sb-c-call:char) ; input speed - (sg-ospeed sb-c-call:char) ; output speed - (sg-erase sb-c-call:char) ; erase character - (sg-kill sb-c-call:char) ; kill character - (sg-flags sb-c-call:short))) ; mode flags + (sg-ispeed sb-alien:char) ; input speed + (sg-ospeed sb-alien:char) ; output speed + (sg-erase sb-alien:char) ; erase character + (sg-kill sb-alien:char) ; kill character + (sg-flags sb-alien:short))) ; mode flags #+OpenBSD -(def-alien-type nil +(define-alien-type nil (struct sgttyb - (sg-four sb-c-call:int) - (sg-chars (array sb-c-call:char 4)) - (sg-flags sb-c-call:int))) + (sg-four sb-alien:int) + (sg-chars (array sb-alien:char 4)) + (sg-flags sb-alien:int))) ;;; Find an unused pty. Return three values: the file descriptor for ;;; the master side of the pty, the file descriptor for the slave side @@ -380,7 +360,7 @@ (when (streamp pty) (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master) (unless new-fd - (error "couldn't SB-UNIX:UNIX-DUP ~D: ~A" master (strerror errno))) + (error "couldn't SB-UNIX:UNIX-DUP ~W: ~A" master (strerror errno))) (push new-fd *close-on-error*) (copy-descriptor-to-stream new-fd pty cookie))) (values name @@ -413,9 +393,9 @@ ;; Blast the string into place. (sb-kernel:copy-to-system-area (the simple-string s) (* sb-vm:vector-data-offset - sb-vm:word-bits) + sb-vm:n-word-bits) string-sap 0 - (* (1+ n) sb-vm:byte-bits)) + (* (1+ n) sb-vm:n-byte-bits)) ;; 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)))) @@ -435,16 +415,17 @@ ,@body) (sb-sys:deallocate-system-memory ,sap ,size))))) -(sb-alien:def-alien-routine spawn sb-c-call:int - (program sb-c-call:c-string) - (argv (* sb-c-call:c-string)) - (envp (* sb-c-call:c-string)) - (pty-name sb-c-call:c-string) - (stdin sb-c-call:int) - (stdout sb-c-call:int) - (stderr sb-c-call:int)) +(sb-alien:define-alien-routine spawn sb-alien:int + (program sb-alien:c-string) + (argv (* sb-alien:c-string)) + (envp (* sb-alien:c-string)) + (pty-name sb-alien:c-string) + (stdin sb-alien:int) + (stdout sb-alien:int) + (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)) (values (and (eq (sb-unix:unix-file-kind unix-filename) :file) @@ -601,9 +582,9 @@ ;; "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. - ;; (I don't want to do it with search lists the way - ;; that CMU CL did, because those are a non-ANSI - ;; extension which I'd like to get rid of. -- WHN) + ;; 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)) (cookie (list 0))) (unless pfile @@ -669,54 +650,54 @@ (setf handler (sb-sys:add-fd-handler descriptor - :input #'(lambda (fd) - (declare (ignore fd)) - (loop - (unless handler - (return)) - (multiple-value-bind - (result readable/errno) - (sb-unix:unix-select (1+ descriptor) - (ash 1 descriptor) - 0 0 0) - (cond ((null result) - (error "~@" - (strerror readable/errno))) - ((zerop result) - (return)))) - (sb-alien:with-alien ((buf (sb-alien:array - sb-c-call:char - 256))) - (multiple-value-bind - (count errno) - (sb-unix:unix-read descriptor - (alien-sap buf) - 256) - (cond ((or (and (null count) - (eql errno sb-unix:eio)) - (eql count 0)) - (sb-sys:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (sb-unix:unix-close descriptor) - (return)) - ((null count) - (sb-sys:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (error - "~@" - (strerror errno))) - (t - (sb-kernel:copy-from-system-area - (alien-sap buf) 0 - string (* sb-vm:vector-data-offset - sb-vm:word-bits) - (* count sb-vm:byte-bits)) - (write-string string stream - :end count))))))))))) + (strerror errno))) + (t + (sb-kernel:copy-from-system-area + (alien-sap buf) 0 + string (* sb-vm:vector-data-offset + sb-vm:n-word-bits) + (* count sb-vm:n-byte-bits)) + (write-string string stream + :end count))))))))))) ;;; Find a file descriptor to use for object given the direction. ;;; Returns the descriptor. If object is :STREAM, returns the created