From 3eb0a28fe6a7912d6ff2b97221325c0e3bfc5703 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 13 Apr 2006 22:52:55 +0000 Subject: [PATCH] 0.9.11.31: misc win32 improvements * Check for correct "expand" in canonicalize-whitespace, and skip canonicalization if it doesn't seem right. (Windows "expand" is something quite different.) * RUN-PROGRAM now always returns a process structure, which reports the exit-code of the process when :WAIT was true. :WAIT nil process-structures still keep their :RUNNING status indefinitely on Windows, though. * FIND-EXECUTABLE-IN-SEARCH-PATH actually searches the path, and adds "exe" as :TYPE if :TYPE is missing on Windows. * ASDF:RUN-SHELL-COMMAND searches for Bourne-shell on Windows, as there is no default location. * SB-GROVEL directly runs gcc and the groveler instead of indirecting via shell, and the groveler directly writes to the lisp-file instead of via stdout and shell redirection. * Hack SB-POSIX till it builds and passes all applicable tests on Windows. Mostly this involved plenty of #-win32, but a few tests needed to be adjusted for the delication Microsoft constitution. * Implement COPY-STREAM in ASDF-INSTALL so that it doesn't have to depend on SB-EXECUTABLE. * Take the .exe suffix into account when installing over an old SBCL on MSYS. * Adjust UNPARSE-NATIVE-WIN32-NAMESTRING slightly: Windows OS functions like stat don't like to have directory names ending with a slash. This is good enough to run unpatched Slime with *COMMUNICATION-STYLE* NIL, and build & pass tests with all contribs except SB-SIMPLE-STREAMS. --- NEWS | 3 + contrib/asdf-install/asdf-install.asd | 1 - contrib/asdf-install/installer.lisp | 25 +- contrib/asdf/asdf.lisp | 4 +- contrib/sb-grovel/def-to-lisp.lisp | 41 ++- contrib/sb-posix/constants.lisp | 39 ++- contrib/sb-posix/defpackage.lisp | 3 + contrib/sb-posix/interface.lisp | 419 ++++++++++++++++------------- contrib/sb-posix/macros.lisp | 3 +- contrib/sb-posix/posix-tests.lisp | 73 +++-- contrib/sb-simple-streams/internal.lisp | 2 +- install.sh | 14 +- src/code/run-program.lisp | 174 ++++++------ src/code/win32-pathname.lisp | 25 +- src/runtime/wrap.c | 3 +- tools-for-build/canonicalize-whitespace | 8 + tools-for-build/canonicalize-whitespace-1 | Bin 805 -> 802 bytes version.lisp-expr | 2 +- 18 files changed, 492 insertions(+), 347 deletions(-) diff --git a/NEWS b/NEWS index 445f213..fe6735c 100644 --- a/NEWS +++ b/NEWS @@ -7,6 +7,9 @@ changes in sbcl-0.9.12 relative to sbcl-0.9.11: ** run-program is implemented (thanks to Mike Thomas) ** sockets support (thanks to Timothy Ritchey) ** better backtrace support (thanks to Alastair Bridgewater) + ** sb-grovel supported + ** asdf-install and sb-posix work somewhat + ** capable of running Slime using SWANK:*COMMUNICATION-STYLE* NIL * minor incompatible change: The reader no longer ignores errors regarding non-existent packages in #+ and #- feature tests. * new feature: command line options --no-sysinit, --no-userinit to diff --git a/contrib/asdf-install/asdf-install.asd b/contrib/asdf-install/asdf-install.asd index ec66a9c..d36609a 100644 --- a/contrib/asdf-install/asdf-install.asd +++ b/contrib/asdf-install/asdf-install.asd @@ -4,7 +4,6 @@ (:use #:cl #:asdf)) (in-package #:asdf-install-system) -(require 'sb-executable) (defsystem asdf-install :depends-on (sb-posix sb-bsd-sockets) diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp index e66ea19..db89bf4 100644 --- a/contrib/asdf-install/installer.lisp +++ b/contrib/asdf-install/installer.lisp @@ -134,6 +134,13 @@ (socket-open-p s)) (socket-close s))))) + +(defun copy-stream (in out) + (let ((buf (make-array 8192 :element-type (stream-element-type in)))) + (loop for pos = (read-sequence buf in) + until (zerop pos) + do (write-sequence buf out :end pos)))) + (defun download-files-for-package (package-name-or-url file-name) (let ((url (if (= (mismatch package-name-or-url "http://") 7) @@ -156,14 +163,13 @@ (format t "Downloading ~A bytes from ~A ..." (if length length "some unknown number of") url) (force-output) - (with-open-file (o file-name :direction :output :element-type '(unsigned-byte 8)) + (with-open-file (out file-name :direction :output + :element-type '(unsigned-byte 8)) (if length - (let ((buf (make-array length - :element-type - '(unsigned-byte 8)))) + (let ((buf (make-array length :element-type '(unsigned-byte 8)))) (read-sequence buf stream) - (write-sequence buf o)) - (sb-executable:copy-stream stream o :element-type '(unsigned-byte 8))))) + (write-sequence buf out)) + (copy-stream stream out)))) (close stream) (terpri) (restart-case @@ -174,7 +180,7 @@ (defun read-until-eof (stream) (with-output-to-string (o) - (sb-executable:copy-stream stream o))) + (copy-stream stream o))) (defun verify-gpg-signature/string (string file-name) (let* ((proc @@ -250,8 +256,8 @@ (defun install-package (source system packagename) "Returns a list of asdf system names for installed asdf systems" - (ensure-directories-exist source ) - (ensure-directories-exist system ) + (ensure-directories-exist source) + (ensure-directories-exist system) (let* ((tar (with-output-to-string (o) (or @@ -279,6 +285,7 @@ system))) (when (probe-file target) (sb-posix:unlink target)) + #-win32 (sb-posix:symlink asd target)) collect (pathname-name asd)))) diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index da1b9bf..098cdfd 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1065,8 +1065,10 @@ output to *verbose-out*. Returns the shell's exit code." #+sbcl (sb-impl::process-exit-code (sb-ext:run-program - "/bin/sh" + #-win32 "/bin/sh" + #+win32 "sh" (list "-c" command) + :search #-win32 nil #+win32 t :input nil :output *verbose-out*)) #+(or cmu scl) diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index 375e847..32b448d 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -17,7 +17,7 @@ (format *default-c-stream* "~A~{ ~A~}~%" (first args) (rest args))) (defun printf (formatter &rest args) - "Emit C code to printf the quoted code, via FORMAT. + "Emit C code to fprintf the quoted code, via FORMAT. The first argument is the C string that should be passed to printf. @@ -33,7 +33,7 @@ code: printf-arg-1 printf-arg-2)" (let ((*print-pretty* nil)) (apply #'format *default-c-stream* - " printf (\"~@?\\n\"~@{, ~A~});~%" + " fprintf (out, \"~@?\\n\"~@{, ~A~});~%" (c-escape formatter) args))) @@ -80,7 +80,17 @@ code: do (format stream "#include <~A>~%" i)) (as-c "#define SIGNEDP(x) (((x)-1)<0)") (as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")") - (as-c "int main() {") + (as-c "int main(int argc, char *argv[]) {") + (as-c " FILE *out;") + (as-c " if (argc != 2) {") + (as-c " printf(\"Invalid argcount!\");") + (as-c " return 1;") + (as-c " } else") + (as-c " out = fopen(argv[1], \"w\");") + (as-c " if (!out) {") + (as-c " printf(\"Error opening output file!\");") + (as-c " return 1;") + (as-c " }") (printf "(cl:in-package #:~A)" package-name) (printf "(cl:eval-when (:compile-toplevel)") (printf " (cl:defparameter *integer-sizes* (cl:make-hash-table))") @@ -164,21 +174,28 @@ code: (terpri) (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL")) filename tmp-c-source (constants-package component)) - (let ((code (run-shell-command "gcc ~A -o ~S ~S" - (if (sb-ext:posix-getenv "EXTRA_CFLAGS") - (sb-ext:posix-getenv "EXTRA_CFLAGS") - "") - (namestring tmp-a-dot-out) - (namestring tmp-c-source)))) + (let ((code (sb-ext:process-exit-code + (sb-ext:run-program "gcc" + (append + (sb-ext:posix-getenv "EXTRA_CFLAGS") + (list "-o" + (namestring tmp-a-dot-out) + (namestring tmp-c-source))) + :search t + :input nil + :output *trace-output*)))) (unless (= code 0) (case (operation-on-failure op) (:warn (warn "~@" op component)) (:error (error 'c-compile-failed :operation op :component component))))) - (let ((code (run-shell-command "~A >~A" - (namestring tmp-a-dot-out) - (namestring tmp-constants)))) + (let ((code (sb-ext:process-exit-code + (sb-ext:run-program (namestring tmp-a-dot-out) + (list (namestring tmp-constants)) + :search nil + :input nil + :output *trace-output*)))) (unless (= code 0) (case (operation-on-failure op) (:warn (warn "~@" diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index 2920c01..98f2fcf 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -6,27 +6,36 @@ (#||# "sys/types.h" "sys/stat.h" - - "sys/socket.h" "sys/un.h" "netinet/in.h" "netinet/in_systm.h" - "netinet/ip.h" "net/if.h" "netinet/tcp.h" "sys/mman.h" "sys/wait.h" + #-win32 "sys/socket.h" + #-win32 "sys/un.h" + #-win32 "netinet/in.h" + #-win32 "netinet/in_systm.h" + #-win32 "netinet/ip.h" + #-win32 "net/if.h" + #-win32 "netinet/tcp.h" + #-win32 "sys/mman.h" + #-win32 "sys/wait.h" "fcntl.h" - "netdb.h" "errno.h" + #-win32 "netdb.h" + "errno.h" "dirent.h" "signal.h" - "pwd.h" + #-win32 "pwd.h" "unistd.h" - - "termios.h") + #-win32 "termios.h") ;;; then the stuff we're looking for ((:integer af-inet "AF_INET" "IP Protocol family" t) - (:type uid-t "uid_t") - (:type gid-t "gid_t") - + ;; KLUDGE: These types simply do not seem to exist on Windows, + ;; but we'll provide these anyways -- at least in a way that should + ;; match with stat. + (:type uid-t #-win32 "uid_t" #+win32 "short") + (:type gid-t #-win32 "gid_t" #+win32 "short") + (:type nlink-t #-win32 "nlink_t" #+win32 "short") + (:type pid-t "pid_t") (:type ino-t "ino_t") - (:type nlink-t "nlink_t") (:type time-t "time_t") (:type dev-t "dev_t") @@ -248,6 +257,7 @@ :distrust-length #+sunos t #-sunos nil)) t) ;; password database + #-win32 (:structure alien-passwd ("struct passwd" (c-string-pointer name "char *" "pw_name") @@ -267,7 +277,7 @@ ;; OS X manpages say this exists. they lie! #+nil (:integer fields "int" "pw_fields"))) - + (:structure alien-stat ("struct stat" (mode-t mode "mode_t" "st_mode") @@ -323,11 +333,14 @@ (:integer f-setown "F_SETOWN" nil t) ;; tcgetattr(), tcsetattr() + #-win32 (:type cc-t "cc_t") + #-win32 (:type speed-t "speed_t" nil t) + #-win32 (:type tcflag-t "tcflag_t" nil t) (:integer nccs "NCCS" nil t) - + #-win32 (:structure alien-termios ("struct termios" (tcflag-t iflag "tcflag_t" "c_iflag") diff --git a/contrib/sb-posix/defpackage.lisp b/contrib/sb-posix/defpackage.lisp index 85524e9..6fc71ca 100644 --- a/contrib/sb-posix/defpackage.lisp +++ b/contrib/sb-posix/defpackage.lisp @@ -14,3 +14,6 @@ #:stat-gid #:stat-size #:stat-atime #:stat-mtime #:stat-ctime #:termios-iflag #:termios-oflag #:termios-cflag #:termios-lflag #:termios-cc)) + +#+win32 +(load-shared-object "msvcrt.dll") diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 1573952..2569a72 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -70,65 +70,36 @@ nil) ;;; filesystem access - -(define-call "access" int minusp (pathname filename) (mode int)) -(define-call "chdir" int minusp (pathname filename)) -(define-call "chmod" int minusp (pathname filename) (mode mode-t)) -(define-call "chown" int minusp (pathname filename) - (owner uid-t) (group gid-t)) -(define-call "chroot" int minusp (pathname filename)) -(define-call "close" int minusp (fd file-descriptor)) -(define-call "creat" int minusp (pathname filename) (mode mode-t)) -(define-call "dup" int minusp (oldfd file-descriptor)) -(define-call "dup2" int minusp (oldfd file-descriptor) (newfd file-descriptor)) -(define-call "fchdir" int minusp (fd file-descriptor)) -(define-call "fchmod" int minusp (fd file-descriptor) (mode mode-t)) -(define-call "fchown" int minusp (fd file-descriptor) - (owner uid-t) (group gid-t)) -(define-call "fdatasync" int minusp (fd file-descriptor)) -(define-call "ftruncate" int minusp (fd file-descriptor) (length off-t)) -(define-call "fsync" int minusp (fd file-descriptor)) -(define-call "lchown" int minusp (pathname filename) - (owner uid-t) (group gid-t)) -(define-call "link" int minusp (oldpath filename) (newpath filename)) -(define-call "lseek" off-t minusp (fd file-descriptor) (offset off-t) (whence int)) -(define-call "mkdir" int minusp (pathname filename) (mode mode-t)) -(define-call "mkfifo" int minusp (pathname filename) (mode mode-t)) -(define-call-internally open-with-mode "open" int minusp (pathname filename) (flags int) (mode mode-t)) -(define-call-internally open-without-mode "open" int minusp (pathname filename) (flags int)) -(define-entry-point "open" (pathname flags &optional (mode nil mode-supplied)) - (if mode-supplied - (open-with-mode pathname flags mode) - (open-without-mode pathname flags))) -;;(define-call "readlink" int minusp (path filename) (buf (* t)) (len int)) +(defmacro define-call* (name &rest arguments) + #-win32 `(define-call ,name ,@arguments) + #+win32 `(define-call ,(concatenate 'string "_" name) ,@arguments)) + +(define-call* "access" int minusp (pathname filename) (mode int)) +(define-call* "chdir" int minusp (pathname filename)) +(define-call* "chmod" int minusp (pathname filename) (mode mode-t)) +(define-call* "close" int minusp (fd file-descriptor)) +(define-call* "creat" int minusp (pathname filename) (mode mode-t)) +(define-call* "dup" int minusp (oldfd file-descriptor)) +(define-call* "dup2" int minusp (oldfd file-descriptor) + (newfd file-descriptor)) +(define-call* "lseek" off-t minusp (fd file-descriptor) (offset off-t) + (whence int)) +(define-call* "mkdir" int minusp (pathname filename) (mode mode-t)) +(macrolet ((def (x) + `(progn + (define-call-internally open-with-mode ,x int minusp + (pathname filename) (flags int) (mode mode-t)) + (define-call-internally open-without-mode ,x int minusp + (pathname filename) (flags int)) + (define-entry-point ,x + (pathname flags &optional (mode nil mode-supplied)) + (if mode-supplied + (open-with-mode pathname flags mode) + (open-without-mode pathname flags)))))) + (def #-win32 "open" #+win32 "_open")) (define-call "rename" int minusp (oldpath filename) (newpath filename)) -(define-call "rmdir" int minusp (pathname filename)) -(define-call "symlink" int minusp (oldpath filename) (newpath filename)) -(define-call "sync" void never-fails) -(define-call "truncate" int minusp (pathname filename) (length off-t)) -(define-call "unlink" int minusp (pathname filename)) -(define-call "mkstemp" int minusp (template c-string)) - -(define-call-internally ioctl-without-arg "ioctl" int minusp (fd file-descriptor) (cmd int)) -(define-call-internally ioctl-with-int-arg "ioctl" int minusp (fd file-descriptor) (cmd int) (arg int)) -(define-call-internally ioctl-with-pointer-arg "ioctl" int minusp (fd file-descriptor) (cmd int) (arg alien-pointer-to-anything-or-nil)) -(define-entry-point "ioctl" (fd cmd &optional (arg nil argp)) - (if argp - (etypecase arg - ((alien int) (ioctl-with-int-arg fd cmd arg)) - ((or (alien (* t)) null) (ioctl-with-pointer-arg fd cmd arg))) - (ioctl-without-arg fd cmd))) - -(define-call-internally fcntl-without-arg "fcntl" int minusp (fd file-descriptor) (cmd int)) -(define-call-internally fcntl-with-int-arg "fcntl" int minusp (fd file-descriptor) (cmd int) (arg int)) -(define-call-internally fcntl-with-pointer-arg "fcntl" int minusp (fd file-descriptor) (cmd int) (arg alien-pointer-to-anything-or-nil)) -(define-entry-point "fcntl" (fd cmd &optional (arg nil argp)) - (if argp - (etypecase arg - ((alien int) (fcntl-with-int-arg fd cmd arg)) - ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg))) - (fcntl-without-arg fd cmd))) - +(define-call* "rmdir" int minusp (pathname filename)) +(define-call* "unlink" int minusp (pathname filename)) (define-call "opendir" (* t) null-alien (pathname filename)) (define-call "readdir" (* dirent) ;; readdir() has the worst error convention in the world. It's just @@ -138,103 +109,154 @@ (dir (* t))) (define-call "closedir" int minusp (dir (* t))) ;; need to do this here because we can't do it in the DEFPACKAGE +(define-call* "umask" mode-t never-fails (mode mode-t)) +(define-call* "getpid" pid-t never-fails) + +#-win32 +(progn + (define-call "chown" int minusp (pathname filename) + (owner uid-t) (group gid-t)) + (define-call "chroot" int minusp (pathname filename)) + (define-call "fchdir" int minusp (fd file-descriptor)) + (define-call "fchmod" int minusp (fd file-descriptor) (mode mode-t)) + (define-call "fchown" int minusp (fd file-descriptor) + (owner uid-t) (group gid-t)) + (define-call "fdatasync" int minusp (fd file-descriptor)) + (define-call "ftruncate" int minusp (fd file-descriptor) (length off-t)) + (define-call "fsync" int minusp (fd file-descriptor)) + (define-call "lchown" int minusp (pathname filename) + (owner uid-t) (group gid-t)) + (define-call "link" int minusp (oldpath filename) (newpath filename)) + (define-call "mkfifo" int minusp (pathname filename) (mode mode-t)) + (define-call "symlink" int minusp (oldpath filename) (newpath filename)) + (define-call "sync" void never-fails) + (define-call "truncate" int minusp (pathname filename) (length off-t)) + ;; FIXME: Windows does have _mktemp, which has a slightlty different + ;; interface + (define-call "mkstemp" int minusp (template c-string)) + (define-call-internally ioctl-without-arg "ioctl" int minusp + (fd file-descriptor) (cmd int)) + (define-call-internally ioctl-with-int-arg "ioctl" int minusp + (fd file-descriptor) (cmd int) (arg int)) + (define-call-internally ioctl-with-pointer-arg "ioctl" int minusp + (fd file-descriptor) (cmd int) + (arg alien-pointer-to-anything-or-nil)) + (define-entry-point "ioctl" (fd cmd &optional (arg nil argp)) + (if argp + (etypecase arg + ((alien int) (ioctl-with-int-arg fd cmd arg)) + ((or (alien (* t)) null) (ioctl-with-pointer-arg fd cmd arg))) + (ioctl-without-arg fd cmd))) + (define-call-internally fcntl-without-arg "fcntl" int minusp + (fd file-descriptor) (cmd int)) + (define-call-internally fcntl-with-int-arg "fcntl" int minusp + (fd file-descriptor) (cmd int) (arg int)) + (define-call-internally fcntl-with-pointer-arg "fcntl" int minusp + (fd file-descriptor) (cmd int) + (arg alien-pointer-to-anything-or-nil)) + (define-entry-point "fcntl" (fd cmd &optional (arg nil argp)) + (if argp + (etypecase arg + ((alien int) (fcntl-with-int-arg fd cmd arg)) + ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg))) + (fcntl-without-arg fd cmd))) + + ;; uid, gid + (define-call "geteuid" uid-t never-fails) ; "always successful", it says + (define-call "getresuid" uid-t never-fails) + (define-call "getuid" uid-t never-fails) + (define-call "seteuid" int minusp (uid uid-t)) + (define-call "setfsuid" int minusp (uid uid-t)) + (define-call "setreuid" int minusp (ruid uid-t) (euid uid-t)) + (define-call "setresuid" int minusp (ruid uid-t) (euid uid-t) (suid uid-t)) + (define-call "setuid" int minusp (uid uid-t)) + (define-call "getegid" gid-t never-fails) + (define-call "getgid" gid-t never-fails) + (define-call "getresgid" gid-t never-fails) + (define-call "setegid" int minusp (gid gid-t)) + (define-call "setfsgid" int minusp (gid gid-t)) + (define-call "setgid" int minusp (gid gid-t)) + (define-call "setregid" int minusp (rgid gid-t) (egid gid-t)) + (define-call "setresgid" int minusp (rgid gid-t) (egid gid-t) (sgid gid-t)) + + ;; processes, signals + (define-call "alarm" int never-fails (seconds unsigned)) + (define-call "fork" pid-t minusp) + (define-call "getpgid" pid-t minusp (pid pid-t)) + (define-call "getppid" pid-t never-fails) + (define-call "getpgrp" pid-t never-fails) + (define-call "getsid" pid-t minusp (pid pid-t)) + (define-call "kill" int minusp (pid pid-t) (signal int)) + (define-call "killpg" int minusp (pgrp int) (signal int)) + (define-call "pause" int minusp) + (define-call "setpgid" int minusp (pid pid-t) (pgid pid-t)) + (define-call "setpgrp" int minusp)) -(define-call "umask" mode-t never-fails (mode mode-t)) - -;;; uid, gid - -(define-call "geteuid" uid-t never-fails) ; "always successful", it says -(define-call "getresuid" uid-t never-fails) -(define-call "getuid" uid-t never-fails) -(define-call "seteuid" int minusp (uid uid-t)) -(define-call "setfsuid" int minusp (uid uid-t)) -(define-call "setreuid" int minusp - (ruid uid-t) (euid uid-t)) -(define-call "setresuid" int minusp - (ruid uid-t) (euid uid-t) - (suid uid-t)) -(define-call "setuid" int minusp (uid uid-t)) - -(define-call "getegid" gid-t never-fails) -(define-call "getgid" gid-t never-fails) -(define-call "getresgid" gid-t never-fails) -(define-call "setegid" int minusp (gid gid-t)) -(define-call "setfsgid" int minusp (gid gid-t)) -(define-call "setgid" int minusp (gid gid-t)) -(define-call "setregid" int minusp - (rgid gid-t) (egid gid-t)) -(define-call "setresgid" int minusp - (rgid gid-t) - (egid gid-t) (sgid gid-t)) - -;;; processes, signals -(define-call "alarm" int never-fails (seconds unsigned)) -(define-call "fork" pid-t minusp) -(define-call "getpgid" pid-t minusp (pid pid-t)) -(define-call "getpid" pid-t never-fails) -(define-call "getppid" pid-t never-fails) -(define-call "getpgrp" pid-t never-fails) -(define-call "getsid" pid-t minusp (pid pid-t)) -(define-call "kill" int minusp (pid pid-t) (signal int)) -(define-call "killpg" int minusp (pgrp int) (signal int)) -(define-call "pause" int minusp) -(define-call "setpgid" int minusp - (pid pid-t) (pgid pid-t)) -(define-call "setpgrp" int minusp) - -(export 'wait :sb-posix) -(declaim (inline wait)) -(defun wait (&optional statusptr) - (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr)) - (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) - (pid (alien-funcall - (extern-alien "wait" (function pid-t (* int))) - (sb-sys:vector-sap ptr)))) - (if (minusp pid) - (syscall-error) - (values pid (aref ptr 0))))) - -(export 'waitpid :sb-posix) -(declaim (inline waitpid)) -(defun waitpid (pid options &optional statusptr) - (declare (type (sb-alien:alien pid-t) pid) - (type (sb-alien:alien int) options) - (type (or null (simple-array (signed-byte 32) (1))) statusptr)) - (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) - (pid (alien-funcall - (extern-alien "waitpid" (function pid-t - pid-t (* int) int)) - pid (sb-sys:vector-sap ptr) options))) - (if (minusp pid) - (syscall-error) - (values pid (aref ptr 0))))) +;;(define-call "readlink" int minusp (path filename) (buf (* t)) (len int)) -;; waitpid macros -(define-call "wifexited" boolean never-fails (status int)) -(define-call "wexitstatus" int never-fails (status int)) -(define-call "wifsignaled" boolean never-fails (status int)) -(define-call "wtermsig" int never-fails (status int)) -(define-call "wifstopped" boolean never-fails (status int)) -(define-call "wstopsig" int never-fails (status int)) -#+nil ; see alien/waitpid-macros.c -(define-call "wifcontinued" boolean never-fails (status int)) +#-win32 +(progn + (export 'wait :sb-posix) + (declaim (inline wait)) + (defun wait (&optional statusptr) + (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr)) + (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) + (pid (alien-funcall + (extern-alien "wait" (function pid-t (* int))) + (sb-sys:vector-sap ptr)))) + (if (minusp pid) + (syscall-error) + (values pid (aref ptr 0)))))) + +#-win32 +(progn + (export 'waitpid :sb-posix) + (declaim (inline waitpid)) + (defun waitpid (pid options &optional statusptr) + (declare (type (sb-alien:alien pid-t) pid) + (type (sb-alien:alien int) options) + (type (or null (simple-array (signed-byte 32) (1))) statusptr)) + (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) + (pid (alien-funcall + (extern-alien "waitpid" (function pid-t + pid-t (* int) int)) + pid (sb-sys:vector-sap ptr) options))) + (if (minusp pid) + (syscall-error) + (values pid (aref ptr 0))))) + ;; waitpid macros + (define-call "wifexited" boolean never-fails (status int)) + (define-call "wexitstatus" int never-fails (status int)) + (define-call "wifsignaled" boolean never-fails (status int)) + (define-call "wtermsig" int never-fails (status int)) + (define-call "wifstopped" boolean never-fails (status int)) + (define-call "wstopsig" int never-fails (status int)) + #+nil ; see alien/waitpid-macros.c + (define-call "wifcontinued" boolean never-fails (status int))) ;;; mmap, msync -(define-call "mmap" sb-sys:system-area-pointer - (lambda (res) - (= (sb-sys:sap-int res) #.(1- (expt 2 sb-vm::n-machine-word-bits)))) - (addr sap-or-nil) (length unsigned) (prot unsigned) - (flags unsigned) (fd file-descriptor) (offset off-t)) +#-win32 +(progn + (define-call "mmap" sb-sys:system-area-pointer + (lambda (res) + (= (sb-sys:sap-int res) #.(1- (expt 2 sb-vm::n-machine-word-bits)))) + (addr sap-or-nil) (length unsigned) (prot unsigned) + (flags unsigned) (fd file-descriptor) (offset off-t)) -(define-call "munmap" int minusp - (start sb-sys:system-area-pointer) (length unsigned)) + (define-call "munmap" int minusp + (start sb-sys:system-area-pointer) (length unsigned)) (define-call "msync" int minusp - (addr sb-sys:system-area-pointer) (length unsigned) (flags int)) + (addr sb-sys:system-area-pointer) (length unsigned) (flags int))) +#-win32 (define-call "getpagesize" int minusp) +#+win32 +;;; KLUDGE: This could be taken from GetSystemInfo +(export (defun getpagesize () 4096)) ;;; passwd database +#-win32 (define-protocol-class passwd alien-passwd () ((name :initarg :name :accessor passwd-name) (passwd :initarg :passwd :accessor passwd-passwd) @@ -245,6 +267,7 @@ (shell :initarg :shell :accessor passwd-shell))) (defmacro define-pw-call (name arg type) + #-win32 ;; FIXME: this isn't the documented way of doing this, surely? (let ((lisp-name (intern (string-upcase name) :sb-posix))) `(progn @@ -256,10 +279,8 @@ r (alien-to-passwd r))))))) -(define-pw-call "getpwnam" login-name - (function (* alien-passwd) c-string)) -(define-pw-call "getpwuid" uid - (function (* alien-passwd) uid-t)) +(define-pw-call "getpwnam" login-name (function (* alien-passwd) c-string)) +(define-pw-call "getpwuid" uid (function (* alien-passwd) uid-t)) (define-protocol-class stat alien-stat () ((mode :initarg :mode :accessor stat-mode) @@ -275,7 +296,7 @@ (defmacro define-stat-call (name arg designator-fun type) ;; FIXME: this isn't the documented way of doing this, surely? - (let ((lisp-name (intern (string-upcase name) :sb-posix))) + (let ((lisp-name (lisp-for-c-symbol name))) `(progn (export ',lisp-name :sb-posix) (declaim (inline ,lisp-name)) @@ -290,11 +311,20 @@ (syscall-error)) (alien-to-stat a-stat stat))))))) -(define-stat-call "stat" pathname filename +(define-stat-call #-win32 "stat" #+win32 "_stat" pathname filename (function int c-string (* alien-stat))) + +#-win32 (define-stat-call "lstat" pathname filename (function int c-string (* alien-stat))) -(define-stat-call "fstat" fd file-descriptor +;;; No symbolic links on Windows, so use stat +#+win32 +(progn + (declaim (inline lstat)) + (export (defun lstat (filename &optional stat) + (if stat (stat filename stat) (stat filename))))) + +(define-stat-call #-win32 "fstat" #+win32 "_fstat" fd file-descriptor (function int int (* alien-stat))) @@ -307,20 +337,23 @@ (define-call "s_islnk" boolean never-fails (mode mode-t)) (define-call "s_issock" boolean never-fails (mode mode-t)) -(export 'pipe :sb-posix) -(declaim (inline pipe)) -(defun pipe (&optional filedes2) - (declare (type (or null (simple-array (signed-byte 32) (2))) filedes2)) - (unless filedes2 - (setq filedes2 (make-array 2 :element-type '(signed-byte 32)))) - (let ((r (alien-funcall - ;; FIXME: (* INT)? (ARRAY INT 2) would be better - (extern-alien "pipe" (function int (* int))) - (sb-sys:vector-sap filedes2)))) - (when (minusp r) - (syscall-error))) - (values (aref filedes2 0) (aref filedes2 1))) - +#-win32 +(progn + (export 'pipe :sb-posix) + (declaim (inline pipe)) + (defun pipe (&optional filedes2) + (declare (type (or null (simple-array (signed-byte 32) (2))) filedes2)) + (unless filedes2 + (setq filedes2 (make-array 2 :element-type '(signed-byte 32)))) + (let ((r (alien-funcall + ;; FIXME: (* INT)? (ARRAY INT 2) would be better + (extern-alien "pipe" (function int (* int))) + (sb-sys:vector-sap filedes2)))) + (when (minusp r) + (syscall-error))) + (values (aref filedes2 0) (aref filedes2 1)))) + +#-win32 (define-protocol-class termios alien-termios () ((iflag :initarg :iflag :accessor sb-posix:termios-iflag) (oflag :initarg :oflag :accessor sb-posix:termios-oflag) @@ -328,33 +361,35 @@ (lflag :initarg :lflag :accessor sb-posix:termios-lflag) (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs))) -(export 'tcsetattr :sb-posix) -(declaim (inline tcsetattr)) -(defun tcsetattr (fd actions termios) - (with-alien-termios a-termios () - (termios-to-alien termios a-termios) - (let ((fd (file-descriptor fd))) - (let* ((r (alien-funcall - (extern-alien - "tcsetattr" - (function int int int (* alien-termios))) - fd actions a-termios))) - (when (minusp r) - (syscall-error))) - (values)))) -(export 'tcgetattr :sb-posix) -(declaim (inline tcgetattr)) -(defun tcgetattr (fd &optional termios) - (with-alien-termios a-termios () - (let ((r (alien-funcall - (extern-alien "tcgetattr" - (function int int (* alien-termios))) - (file-descriptor fd) - a-termios))) - (when (minusp r) - (syscall-error)) - (setf termios (alien-to-termios a-termios termios)))) - termios) +#-win32 +(progn + (export 'tcsetattr :sb-posix) + (declaim (inline tcsetattr)) + (defun tcsetattr (fd actions termios) + (with-alien-termios a-termios () + (termios-to-alien termios a-termios) + (let ((fd (file-descriptor fd))) + (let* ((r (alien-funcall + (extern-alien + "tcsetattr" + (function int int int (* alien-termios))) + fd actions a-termios))) + (when (minusp r) + (syscall-error))) + (values)))) + (export 'tcgetattr :sb-posix) + (declaim (inline tcgetattr)) + (defun tcgetattr (fd &optional termios) + (with-alien-termios a-termios () + (let ((r (alien-funcall + (extern-alien "tcgetattr" + (function int int (* alien-termios))) + (file-descriptor fd) + a-termios))) + (when (minusp r) + (syscall-error)) + (setf termios (alien-to-termios a-termios termios)))) + termios)) ;;; environment diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index c691826..02855f8 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -18,7 +18,8 @@ ((alien (* t)) alien-pointer-to-anything-or-nil)) (defun lisp-for-c-symbol (s) - (intern (substitute #\- #\_ (string-upcase s)) :sb-posix)) + (let ((root (if (eql #\_ (char s 0)) (subseq s 1) s))) + (intern (substitute #\- #\_ (string-upcase root)) :sb-posix))) (defmacro define-call-internally (lisp-name c-name return-type error-predicate &rest arguments) diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index ee7399b..9b2ce3a 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -14,11 +14,15 @@ (defvar *this-file* *load-truename*) (eval-when (:compile-toplevel :load-toplevel) - (defconstant +mode-rwx-all+ (logior sb-posix::s-irusr sb-posix::s-iwusr sb-posix::s-ixusr - sb-posix::s-irgrp sb-posix::s-iwgrp sb-posix::s-ixgrp - sb-posix::s-iroth sb-posix::s-iwoth sb-posix::s-ixoth))) + (defconstant +mode-rwx-all+ + (logior sb-posix::s-irusr sb-posix::s-iwusr sb-posix::s-ixusr + #-win32 + (logior + sb-posix::s-irgrp sb-posix::s-iwgrp sb-posix::s-ixgrp + sb-posix::s-iroth sb-posix::s-iwoth sb-posix::s-ixoth)))) (defmacro define-eacces-test (name form &rest values) + #-win32 `(deftest ,name (block ,name (when (= (sb-posix:geteuid) 0) @@ -31,19 +35,19 @@ 0) (deftest chdir.2 - (sb-posix:chdir (namestring *test-directory*)) + (sb-posix:chdir (namestring *test-directory*)) 0) (deftest chdir.3 - (sb-posix:chdir "/") + (sb-posix:chdir "/") 0) (deftest chdir.4 - (sb-posix:chdir #p"/") + (sb-posix:chdir #p"/") 0) (deftest chdir.5 - (sb-posix:chdir *current-directory*) + (sb-posix:chdir *current-directory*) 0) (deftest chdir.6 @@ -71,7 +75,10 @@ (sb-posix:chdir *this-file*) (sb-posix:syscall-error (c) (sb-posix:syscall-errno c))) - #.sb-posix::enotdir) + #-win32 + #.sb-posix:enotdir + #+win32 + #.sb-posix:einval) (deftest mkdir.1 (let ((dne (make-pathname :directory '(:relative "mkdir.does-not-exist.1")))) @@ -98,10 +105,13 @@ (deftest mkdir.error.2 (handler-case - (sb-posix:mkdir "/" 0) + (sb-posix:mkdir #-win32 "/" #+win32 "C:/" 0) (sb-posix:syscall-error (c) (sb-posix:syscall-errno c))) - #.sb-posix::eexist) + #-win32 + #.sb-posix::eexist + #+win32 + #.sb-posix:eacces) (define-eacces-test mkdir.error.3 (let* ((dir (merge-pathnames @@ -147,14 +157,20 @@ (sb-posix:rmdir *this-file*) (sb-posix:syscall-error (c) (sb-posix:syscall-errno c))) - #.sb-posix::enotdir) + #-win32 + #.sb-posix::enotdir + #+win32 + #.sb-posix::einval) (deftest rmdir.error.3 (handler-case - (sb-posix:rmdir "/") + (sb-posix:rmdir #-win32 "/" #+win32 "C:/") (sb-posix:syscall-error (c) (sb-posix:syscall-errno c))) - #.sb-posix::ebusy) + #-win32 + #.sb-posix::ebusy + #+win32 + #.sb-posix::eacces) (deftest rmdir.error.4 (let* ((dir (ensure-directories-exist @@ -162,7 +178,7 @@ (make-pathname :directory '(:relative "rmdir.error.4")) *test-directory*))) (file (make-pathname :name "foo" :defaults dir))) - (with-open-file (s file :direction :output) + (with-open-file (s file :direction :output :if-exists nil) (write "" :stream s)) (handler-case (sb-posix:rmdir dir) @@ -204,6 +220,7 @@ (logand mode (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec))) #.(logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) +#-win32 (deftest stat.2 (let* ((stat (sb-posix:stat "/")) (mode (sb-posix::stat-mode stat))) @@ -223,6 +240,7 @@ (< (- atime unix-now) 10)) t) +#-win32 (deftest stat.4 (let* ((stat (sb-posix:stat (make-pathname :directory '(:absolute :up)))) (mode (sb-posix::stat-mode stat))) @@ -304,11 +322,13 @@ (sb-posix:s-isfifo mode)) nil) +#-win32 (deftest stat-mode.6 (with-stat-mode (mode *test-directory*) (sb-posix:s-issock mode)) nil) +#-win32 (deftest stat-mode.7 (let ((link-pathname (make-pathname :name "stat-mode.7" :defaults *test-directory*))) @@ -332,11 +352,14 @@ (ignore-errors (delete-file pathname)))) t) +(defvar *test-directory* (merge-pathnames "test-lab/")) ;;; see comment in filename's designator definition, in macros.lisp (deftest filename-designator.1 (let ((file (format nil "~A/[foo].txt" (namestring *test-directory*)))) ;; creat() with a string as argument - (sb-posix:creat file 0) + (let ((fd (sb-posix:creat file sb-posix:s-iwrite))) + #+win32 + (sb-posix:close fd)) ;; if this test fails, it will probably be with ;; "System call error 2 (No such file or directory)" (let ((*default-pathname-defaults* *test-directory*)) @@ -344,18 +367,26 @@ 0) (deftest open.1 - (let ((fd (sb-posix:open *test-directory* sb-posix::o-rdonly))) - (ignore-errors (sb-posix:close fd)) - (< fd 0)) + (let ((name (merge-pathnames "open-test.txt" *test-directory*))) + (unwind-protect + (progn + (sb-posix:close (sb-posix:creat name sb-posix:s-iwrite)) + (let ((fd (sb-posix:open name sb-posix::o-rdonly))) + (ignore-errors (sb-posix:close fd)) + (< fd 0))) + (ignore-errors (sb-posix:unlink name)))) nil) (deftest open.error.1 (handler-case (sb-posix:open *test-directory* sb-posix::o-wronly) (sb-posix:syscall-error (c) (sb-posix:syscall-errno c))) - #.sb-posix::eisdir) + #-win32 + #.sb-posix::eisdir + #+win32 + #.sb-posix:eacces) -#-(and x86-64 linux) +#-(or (and x86-64 linux) win32) (deftest fcntl.1 (let ((fd (sb-posix:open "/dev/null" sb-posix::o-nonblock))) (= (sb-posix:fcntl fd sb-posix::f-getfl) sb-posix::o-nonblock)) @@ -388,11 +419,13 @@ (sb-posix:closedir dir))) t) +#-win32 (deftest pwent.1 ;; make sure that we found something (not (sb-posix:getpwuid 0)) nil) +#-win32 (deftest pwent.2 ;; make sure that we found something (not (sb-posix:getpwnam "root")) diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp index 8b32d9e..44eff2b 100644 --- a/contrib/sb-simple-streams/internal.lisp +++ b/contrib/sb-simple-streams/internal.lisp @@ -332,7 +332,7 @@ (tagbody again ;; Avoid CMUCL gengc write barrier - (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize))))) + (do ((i start (+ i #.(sb-posix:getpagesize)))) ((>= i end)) (declare (type fixnum i)) (setf (bref buffer i) 0)) diff --git a/install.sh b/install.sh index a2399f0..51f8634 100644 --- a/install.sh +++ b/install.sh @@ -48,10 +48,20 @@ ensure_dirs $BUILD_ROOT$INSTALL_ROOT $BUILD_ROOT$INSTALL_ROOT/bin \ $BUILD_ROOT$SBCL_HOME \ $BUILD_ROOT$SBCL_HOME/site-systems +if [ "$OSTYPE" = "msys" ] +then + RUNTIME=sbcl.exe + OLD_RUNTIME=sbcl_old.exe +else + RUNTIME=sbcl + OLD_RUNTIME=sbcl.old +fi + # move old versions out of the way. Safer than copying: don't want to # break any running instances that have these files mapped -test -f $BUILD_ROOT$INSTALL_ROOT/bin/sbcl && \ - mv $BUILD_ROOT$INSTALL_ROOT/bin/sbcl $BUILD_ROOT$INSTALL_ROOT/bin/sbcl.old +test -f $BUILD_ROOT$INSTALL_ROOT/bin/$RUNTIME && \ + mv $BUILD_ROOT$INSTALL_ROOT/bin/$RUNTIME \ + $BUILD_ROOT$INSTALL_ROOT/bin/$OLD_RUNTIME test -f $BUILD_ROOT$SBCL_HOME/sbcl.core && \ mv $BUILD_ROOT$SBCL_HOME/sbcl.core $BUILD_ROOT$SBCL_HOME/sbcl.core.old diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 38a6f0f..537b367 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -45,10 +45,12 @@ ;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not ;;;; visible at GENESIS time. -#-win32 (define-alien-routine wrapped-environ (* c-string)) -#-win32 (defun posix-environ () - "Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs." - (c-strings->string-list (wrapped-environ))) +#-win32 +(progn + (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 (wrapped-environ)))) ;#+win32 (sb-alien:define-alien-routine msvcrt-environ (* c-string)) @@ -157,7 +159,6 @@ (sb-thread:with-mutex (*active-processes-lock*) ,@body))) - (defstruct (process (:copier nil)) pid ; PID of child process %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED @@ -171,15 +172,13 @@ plist ; a place for clients to stash things cookie) ; list of the number of pipes from the subproc - - -#-win32 (defmethod print-object ((process process) stream) +(defmethod print-object ((process process) stream) (print-unreadable-object (process stream :type t) - (format stream - "~W ~S" - (process-pid process) - (process-status process))) - process) + (let ((status (process-status process))) + (if (eq :exited status) + (format stream "~S ~S" status (process-exit-code process)) + (format stream "~S ~S" (process-pid process) status))) + process)) #+sb-doc (setf (documentation 'process-p 'function) @@ -188,12 +187,12 @@ #+sb-doc (setf (documentation 'process-pid 'function) "The pid of the child process.") -#-win32 (defun process-status (process) #+sb-doc "Return the current status of PROCESS. The result is one of :RUNNING, :STOPPED, :EXITED, or :SIGNALED." - (get-processes-status-changes) + #-win32 + (get-processes-status-changes) (process-%status process)) #+sb-doc @@ -324,11 +323,13 @@ The function is called with PROCESS as its only argument.") process) ;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes -#-win32 (defun sigchld-handler (ignore1 ignore2 ignore3) +#-win32 +(defun sigchld-handler (ignore1 ignore2 ignore3) (declare (ignore ignore1 ignore2 ignore3)) (get-processes-status-changes)) -#-win32 (defun get-processes-status-changes () +#-win32 +(defun get-processes-status-changes () (loop (multiple-value-bind (pid what code core) (wait3 t t) @@ -356,12 +357,14 @@ The function is called with PROCESS as its only argument.") (defvar *close-in-parent* nil) ;;; list of handlers installed by RUN-PROGRAM -#-win32 (defvar *handlers-installed* nil) +#-win32 +(defvar *handlers-installed* nil) ;;; Find an unused pty. Return three values: the file descriptor for ;;; 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 () +#-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)) @@ -381,7 +384,8 @@ The function is called with PROCESS as its only argument.") (sb-unix:unix-close master-fd)))))) (error "could not find a pty")) -#-win32 (defun open-pty (pty cookie) +#-win32 +(defun open-pty (pty cookie) (when pty (multiple-value-bind (master slave name) @@ -451,7 +455,8 @@ The function is called with PROCESS as its only argument.") ,@body) (sb-sys:deallocate-system-memory ,sap ,size))))) -#-win32 (sb-alien:define-alien-routine spawn sb-alien:int +#-win32 +(sb-alien:define-alien-routine spawn sb-alien:int (program sb-alien:c-string) (argv (* sb-alien:c-string)) (envp (* sb-alien:c-string)) @@ -460,7 +465,8 @@ The function is called with PROCESS as its only argument.") (stdout sb-alien:int) (stderr sb-alien:int)) -#+win32 (sb-alien:define-alien-routine spawn sb-win32::handle +#+win32 +(sb-alien:define-alien-routine spawn sb-win32::handle (program sb-alien:c-string) (argv (* sb-alien:c-string)) (stdin sb-alien:int) @@ -469,30 +475,31 @@ The function is called with PROCESS as its only argument.") (wait sb-alien:int)) ;;; Is UNIX-FILENAME the name of a file that we can execute? -#-win32 (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 +(defun unix-filename-is-executable-p (unix-filename) + (let ((filename (coerce unix-filename 'base-string))) + (values (and (eq (sb-unix:unix-file-kind filename) :file) + #-win32 + (sb-unix:unix-access filename sb-unix:x_ok))))) + +(defun find-executable-in-search-path (pathname &optional (search-path (posix-getenv "PATH"))) #+sb-doc "Find the first executable file matching PATHNAME in any of the colon-separated list of pathnames SEARCH-PATH" - (loop for end = (position #-win32 #\: #+win32 #\; 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 #-win32 (and fullpath - (unix-filename-is-executable-p (namestring fullpath))) - #+win32 t - return fullpath)) + (let ((program #-win32 pathname + #+win32 (merge-pathnames pathname (make-pathname :type "exe")))) + (loop for end = (position #-win32 #\: #+win32 #\; 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 + (unix-namestring (merge-pathnames program truename))) + when (and fullpath (unix-filename-is-executable-p fullpath)) + return fullpath))) ;;; FIXME: There shouldn't be two semiredundant versions of the ;;; documentation. Since this is a public extension function, the @@ -538,7 +545,8 @@ colon-separated list of pathnames SEARCH-PATH" ;;; RUN-PROGRAM returns a PROCESS structure for the process if ;;; the fork worked, and NIL if it did not. -#-win32 (defun run-program (program args +#-win32 +(defun run-program (program args &key (env nil env-p) (environment (if env-p @@ -556,14 +564,14 @@ colon-separated list of pathnames SEARCH-PATH" (if-error-exists :error) status-hook) #+sb-doc - "RUN-PROGRAM creates a new Unix process running the Unix program found in - the file specified by the PROGRAM argument. ARGS are the standard - arguments that can be passed to a Unix program. For no arguments, use NIL - (which means that just the name of the program is passed as arg 0). + "RUN-PROGRAM creates a new Unix process running the Unix program +found in the file specified by the PROGRAM argument. ARGS are the +standard arguments that can be passed to a Unix program. For no +arguments, use NIL (which means that just the name of the program is +passed as arg 0). - RUN-PROGRAM will return a PROCESS structure or NIL on failure. - See the CMU Common Lisp Users Manual for details about the - PROCESS structure. +RUN-PROGRAM will return a PROCESS structure. See the CMU Common Lisp +Users Manual for details about the PROCESS structure. Notes about Unix environments (as in the :ENVIRONMENT and :ENV args): @@ -631,7 +639,6 @@ colon-separated list of pathnames SEARCH-PATH" :STATUS-HOOK This is a function the system calls whenever the status of the process changes. The function takes the process as an argument." - (when (and env-p environment-p) (error "can't specify :ENV and :ENVIRONMENT simultaneously")) ;; Make sure that the interrupt handler is installed. @@ -651,9 +658,8 @@ colon-separated list of pathnames SEARCH-PATH" (unwind-protect (let ((pfile (if search - (let ((p (find-executable-in-search-path program))) - (and p (unix-namestring p t))) - (unix-namestring program t))) + (find-executable-in-search-path program) + (unix-namestring program))) (cookie (list 0))) (unless pfile (error "no such program: ~S" program)) @@ -708,7 +714,8 @@ colon-separated list of pathnames SEARCH-PATH" (process-wait proc)) proc)) -#+win32 (defun run-program (program args +#+win32 +(defun run-program (program args &key (wait t) search @@ -719,13 +726,13 @@ colon-separated list of pathnames SEARCH-PATH" (error :output) (if-error-exists :error) status-hook) - "RUN-PROGRAM creates a new process specified by the PROGRAM argument. - ARGS are the standard arguments that can be passed to a program. For no - arguments, use NIL (which means that just the name of the program is - passed as arg 0). + "RUN-PROGRAM creates a new process specified by the PROGRAM +argument. ARGS are the standard arguments that can be passed to a +program. For no arguments, use NIL (which means that just the name of +the program is passed as arg 0). - RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU - Common Lisp Users Manual for details about the PROCESS structure. +RUN-PROGRAM will either return a PROCESS structure. See the CMU +Common Lisp Users Manual for details about the PROCESS structure. The &KEY arguments have the following meanings: :SEARCH @@ -767,7 +774,6 @@ colon-separated list of pathnames SEARCH-PATH" :STATUS-HOOK This is a function the system calls whenever the status of the process changes. The function takes the process as an argument." - ;; Prepend the program to the argument list. (push (namestring program) args) (let (;; Clear various specials used by GET-DESCRIPTOR-FOR to @@ -782,11 +788,13 @@ colon-separated list of pathnames SEARCH-PATH" (unwind-protect (let ((pfile (if search - (namestring (find-executable-in-search-path program)) - (namestring program))) + (find-executable-in-search-path program) + (unix-namestring program))) (cookie (list 0))) (unless pfile - (error "no such program: ~S" program)) + (error "No such program: ~S" program)) + (unless (unix-filename-is-executable-p pfile) + (error "Not an executable: ~S" program)) (multiple-value-bind (stdin input-stream) (get-descriptor-for input cookie :direction :input @@ -802,26 +810,23 @@ colon-separated list of pathnames SEARCH-PATH" :direction :output :if-exists if-error-exists)) (with-c-strvec (args-vec simple-args) - (let ((iwait (if wait 1 0))) - (declare (type fixnum iwait)) - (let ((child-pid - (without-gcing - (spawn pfile args-vec - stdin stdout stderr - iwait)))) - (when (< child-pid 0) - (error "couldn't spawn program: ~A" - (strerror))) + (let ((handle (without-gcing + (spawn pfile args-vec + stdin stdout stderr + (if wait 1 0))))) + (when (< handle 0) + (error "Couldn't spawn program: ~A" (strerror))) (setf proc (if wait - nil - (make-process :pid child-pid - :%status :running - :input input-stream - :output output-stream - :error error-stream - :status-hook status-hook - :cookie cookie))))))))))) + (make-process :%status :exited + :exit-code handle) + (make-process :pid handle + :%status :running + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie)))))))))) proc)) ;;; Install a handler for any input that shows up on the file @@ -953,7 +958,8 @@ colon-separated list of pathnames SEARCH-PATH" (dotimes (count 256 (error "could not open a temporary file in /tmp")) - (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) 'base-string)) + (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 diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index 0b5872a..4a3d10b 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -266,18 +266,25 @@ (when device (write-string device s) (write-char #\: s)) - (ecase (car directory) - (:absolute (write-char #\\ s)) - (:relative)) - (dolist (piece (cdr directory)) - (typecase piece - ((member :up) (write-string ".." s)) - (string (write-string piece s)) - (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))) - (write-char #\\ s)) + (tagbody + (ecase (pop directory) + (:absolute (write-char #\\ s)) + (:relative)) + (unless directory (go :done)) + :subdir + (let ((piece (pop directory))) + (typecase piece + ((member :up) (write-string ".." s)) + (string (write-string piece s)) + (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))) + (when directory + (write-char #\\ s) + (go :subdir)) + :done) (when name (unless (stringp name) (error "non-STRING name in NATIVE-NAMESTRING: ~S" name)) + (write-char #\\ s) (write-string name s) (when type (unless (stringp type) diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c index 153ebd5..0b715c7 100644 --- a/src/runtime/wrap.c +++ b/src/runtime/wrap.c @@ -452,9 +452,9 @@ int wifstopped(int status) { int wstopsig(int status) { return WSTOPSIG(status); } - /* FIXME: POSIX also defines WIFCONTINUED, but that appears not to exist on at least Linux... */ +#endif /* !LISP_FEATURE_WIN32 */ /* From SB-POSIX, stat-macros */ int s_isreg(mode_t mode) @@ -477,6 +477,7 @@ int s_isfifo(mode_t mode) { return S_ISFIFO(mode); } +#ifndef LISP_FEATURE_WIN32 int s_islnk(mode_t mode) { #ifdef S_ISLNK diff --git a/tools-for-build/canonicalize-whitespace b/tools-for-build/canonicalize-whitespace index 5c64e69..c487a22 100755 --- a/tools-for-build/canonicalize-whitespace +++ b/tools-for-build/canonicalize-whitespace @@ -5,5 +5,13 @@ # Convert tabs to spaces and delete trailing whitespace in files # which we can safely assume to be source files in appropriate languages. +if ! expand --version +then + # If we're building with MSYS on Windows GNU expand is not available, + # and what we get is Microsoft Expand, which is something quite different, + # so bail out. + exit +fi + tools-for-build/whitespacely-canonical-filenames \ | xargs tools-for-build/canonicalize-whitespace-1 diff --git a/tools-for-build/canonicalize-whitespace-1 b/tools-for-build/canonicalize-whitespace-1 index de19e97bec6896bd50919f7dc49c5dbedf2d371e..431c1cbbf7c3f7899f446513a907cb9d4b641514 100755 GIT binary patch delta 12 TcmZ3=wuo&*0^{an#zTw%9Zdv3 delta 15 WcmZ3)wv=r{0wWU_!{&I#!;AnVz63}B diff --git a/version.lisp-expr b/version.lisp-expr index 33b47be..158e71c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.11.30" +"0.9.11.31" -- 1.7.10.4