common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.9.11.31: misc win32 improvements

Browse source 
* 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.
This commit is contained in:
Nikodemus Siivola 2006-04-13 22:52:55 +00:00
parent 84e9f00b07
commit 3eb0a28fe6
18 changed files with 485 additions and 340 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
NEWS
View file

@ -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

1
contrib/asdf-install/asdf-install.asd
View file

@ -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)

25
contrib/asdf-install/installer.lisp
View file

@ -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))))

4
contrib/asdf/asdf.lisp
View file

@ -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)

41
contrib/sb-grovel/def-to-lisp.lisp
View file

@ -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 "~@<C compiler failure when performing ~A on ~A.~@:>"
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 "~@<a.out failure when performing ~A on ~A.~@:>"

39
contrib/sb-posix/constants.lisp
View file

@ -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")

3
contrib/sb-posix/defpackage.lisp
View file

@ -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")

407
contrib/sb-posix/interface.lisp
View file

@ -70,65 +70,36 @@
nil)
;;; filesystem access
(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 "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))
(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)
(define-call "umask" mode-t never-fails (mode mode-t))
#-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
;; 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))
(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))
;; 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 "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))
;;(define-call "readlink" int minusp (path filename) (buf (* t)) (len int))
;;; 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)
#-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))))))
(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)))))
;; 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 '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

3
contrib/sb-posix/macros.lisp
View file

@ -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)

73
contrib/sb-posix/posix-tests.lisp
View file

@ -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"))

2
contrib/sb-simple-streams/internal.lisp
View file

@ -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))

14
install.sh
View file

@ -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

172
src/code/run-program.lisp
View file

@ -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 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
(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
;; <Krystof> 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
;; <Krystof> 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

25
src/code/win32-pathname.lisp
View file

@ -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)

3
src/runtime/wrap.c
View file

@ -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

8
tools-for-build/canonicalize-whitespace
View file

@ -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

BIN
tools-for-build/canonicalize-whitespace-1
View file

Binary file not shown.

2
version.lisp-expr
View file

@ -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"