** 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
(:use #:cl #:asdf))
(in-package #:asdf-install-system)
-(require 'sb-executable)
(defsystem asdf-install
:depends-on (sb-posix sb-bsd-sockets)
(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)
(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
(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
(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
system)))
(when (probe-file target)
(sb-posix:unlink target))
+ #-win32
(sb-posix:symlink asd target))
collect (pathname-name asd))))
#+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)
(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.
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)))
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))")
(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.~@:>"
(#||#
"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")
:distrust-length #+sunos t #-sunos nil)) t)
;; password database
+ #-win32
(:structure alien-passwd
("struct passwd"
(c-string-pointer name "char *" "pw_name")
;; 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")
(: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")
#: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")
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
(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)
(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
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)
(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))
(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)))
(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)
(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
((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)
(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)
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
(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)
\f
(deftest mkdir.1
(let ((dne (make-pathname :directory '(:relative "mkdir.does-not-exist.1"))))
(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
(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
(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)
(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)))
(< (- 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)))
(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*)))
(ignore-errors (delete-file pathname))))
t)
\f
+(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*))
0)
\f
(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))
(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"))
(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))
$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
;;;; 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))
(sb-thread:with-mutex (*active-processes-lock*)
,@body)))
-
(defstruct (process (:copier nil))
pid ; PID of child process
%status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
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)
#+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
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)
(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))
(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)
,@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))
(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)
(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
- ;; <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
;;; 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
(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):
: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.
(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))
(process-wait proc))
proc))
-#+win32 (defun run-program (program args
+#+win32
+(defun run-program (program args
&key
(wait t)
search
(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
: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
(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
: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
(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
(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)
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)
{
return S_ISFIFO(mode);
}
+#ifndef LISP_FEATURE_WIN32
int s_islnk(mode_t mode)
{
#ifdef S_ISLNK
# 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
;;; 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"
projects / sbcl.git / commitdiff