Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5900/src/code
Modified Files:
Tag: lutex-branch
x86-vm.lisp win32.lisp win32-pathname.lisp unix.lisp
toplevel.lisp target-signal.lisp target-format.lisp
sharpm.lisp run-program.lisp reader.lisp pred.lisp octets.lisp
late-type.lisp irrat.lisp filesys.lisp fd-stream.lisp
eval.lisp error.lisp early-package.lisp early-fasl.lisp
defstruct.lisp debug-int.lisp cross-misc.lisp
Log Message:
0.9.11.45.lutex-branch.32
* merging 0.9.11.45 changes onto the lutex branch
Index: x86-vm.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/x86-vm.lisp,v
retrieving revision 1.30
retrieving revision 1.30.6.1
diff -u -d -r1.30 -r1.30.6.1
--- x86-vm.lisp 14 Jul 2005 16:30:41 -0000 1.30
+++ x86-vm.lisp 22 Apr 2006 03:08:08 -0000 1.30.6.1
@@ -255,7 +255,7 @@
;;; Given a signal context, return the floating point modes word in
;;; the same format as returned by FLOATING-POINT-MODES.
-#!-linux
+#!-(or linux sunos)
(defun context-floating-point-modes (context)
;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
;; POSIXness and (at the Lisp level) opaque signal contexts,
@@ -263,21 +263,9 @@
;; alien function.
(declare (ignore context)) ; stub!
(warn "stub CONTEXT-FLOATING-POINT-MODES")
-
- ;; old code for Linux:
- #+nil
- (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw))
- (sw (slot (deref (slot context 'fpstate) 0) 'sw)))
- ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw)
- ;; NOT TESTED -- Clear sticky bits to clear interrupt condition.
- (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f))
- ;;(format t "new sw = ~X~%" (slot (deref (slot context 'fpstate) 0) 'sw))
- ;; Simulate floating-point-modes VOP.
- (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))
-
0)
-#!+linux
+#!+(or linux sunos)
(define-alien-routine ("os_context_fp_control" context-floating-point-modes)
(sb!alien:unsigned 32)
(context (* os-context-t)))
Index: win32.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/win32.lisp,v
retrieving revision 1.2
retrieving revision 1.2.2.1
diff -u -d -r1.2 -r1.2.2.1
--- win32.lisp 21 Mar 2006 15:51:51 -0000 1.2
+++ win32.lisp 22 Apr 2006 03:08:08 -0000 1.2.2.1
@@ -21,6 +21,10 @@
(define-alien-type dword unsigned-long)
(define-alien-type bool int)
(define-alien-type UINT unsigned-int)
+(define-alien-type tchar #!+sb-unicode (sb!alien:unsigned 16)
+ #!-sb-unicode char)
+
+(defconstant default-environment-length 1024)
;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
;;; to a pointer.
@@ -151,11 +155,11 @@
(define-alien-routine ("Sleep@..." millisleep) void
(milliseconds dword))
-#!+sb-unicode (defvar *ANSI-CP* nil)
-#!+sb-unicode (defvar *OEM-CP* nil)
+#!+sb-unicode (defvar *ANSI-CODEPAGE* nil)
+#!+sb-unicode (defvar *OEM-CODEPAGE* nil)
#!+sb-unicode
-(defparameter *cp-to-external-format* (make-hash-table))
+(defparameter *codepage-to-external-format* (make-hash-table))
#!+sb-unicode
(dolist (cp
@@ -309,26 +313,164 @@
;;57011 ISCII Punjabi
;;65000 Unicode UTF-7
(65001 :UTF8))) ;; Unicode UTF-8
- (setf (gethash (car cp) *cp-to-external-format*) (cadr cp)))
+ (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
#!+sb-unicode
-(declaim (ftype (function () keyword) ansi-cp))
+(declaim (ftype (function () keyword) ansi-codepage))
#!+sb-unicode
-(defun ansi-cp ()
- (or *ANSI-CP*
- (setq *ANSI-CP*
+(defun ansi-codepage ()
+ (or *ANSI-CODEPAGE*
+ (setq *ANSI-CODEPAGE*
(or
(gethash (alien-funcall (extern-alien "GetACP@..." (function UINT)))
- *cp-to-external-format*)
+ *codepage-to-external-format*)
:LATIN-1))))
#!+sb-unicode
-(declaim (ftype (function () keyword) oem-cp))
+(declaim (ftype (function () keyword) oem-codepage))
#!+sb-unicode
-(defun oem-cp ()
- (or *OEM-CP*
- (setq *OEM-CP*
+(defun oem-codepage ()
+ (or *OEM-CODEPAGE*
+ (setq *OEM-CODEPAGE*
(or
(gethash (alien-funcall (extern-alien "GetOEMCP@..." (function UINT)))
- *cp-to-external-format*)
+ *codepage-to-external-format*)
:LATIN-1))))
+
+;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
+(declaim (ftype (function () keyword) console-input-codepage))
+(defun console-input-codepage ()
+ (or #!+sb-unicode
+ (gethash (alien-funcall (extern-alien "GetConsoleCP@..." (function UINT)))
+ *codepage-to-external-format*)
+ :LATIN-1))
+
+;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
+(declaim (ftype (function () keyword) console-output-codepage))
+(defun console-output-codepage ()
+ (or #!+sb-unicode
+ (gethash (alien-funcall (extern-alien "GetConsoleOutputCP@..." (function UINT)))
+ *codepage-to-external-format*)
+ :LATIN-1))
+
+;;;; FIXME (rudi 2006-03-29): this should really be (octets-to-string
+;;;; :external-format :ucs2), except that we do not have an
+;;;; implementation of ucs2 yet.
+(defmacro ucs2->string (astr &optional size)
+ #!-sb-unicode
+ (declare (ignore size))
+ #!-sb-unicode
+ `(cast ,astr c-string)
+ #!+sb-unicode
+ (let ((str-len (or size `(do ((i 0 (1+ i))) ((zerop (deref ,astr i)) i)))))
+ `(let* ((l ,str-len)
+ (s (make-string l)))
+ (dotimes (i l) (setf (aref s i) (code-char (deref ,astr i))))
+ s)))
+
+(defmacro ucs2->string&free (astr &optional size)
+ `(prog1 (ucs2->string ,astr ,size) (free-alien ,astr)))
+
+(define-alien-routine ("LocalFree@..." local-free) void
+ (lptr (* t)))
+
+(defun get-last-error-message (err)
+ "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
+ (with-alien ((amsg (* tchar)))
+ (let ((nchars
+ (alien-funcall
+ (extern-alien #!+sb-unicode "FormatMessageW@..."
+ #!-sb-unicode "FormatMessageA@..."
+ (function dword
+ dword dword dword dword (* (* tchar)) dword dword))
+ (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
+ 0 err 0 (addr amsg) 0 0)))
+ (prog1 (ucs2->string amsg nchars)
+ (local-free amsg)))))
+
+(defmacro win32-error (func-name)
+ `(let ((err-code (sb!win32::get-last-error)))
+ (error "~%Win32 Error [~A] - ~A~%~A"
+ ,func-name
+ err-code
+ (sb!win32::get-last-error-message err-code))))
+
+(defun get-folder-path (CSIDL)
+ "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
+ (with-alien ((apath (* tchar) (make-alien tchar (1+ MAX_PATH))))
+ (alien-funcall
+ (extern-alien #!-sb-unicode "SHGetFolderPathA@..."
+ #!+sb-unicode "SHGetFolderPathW@..."
+ (function int handle int handle dword (* tchar)))
+ 0 CSIDL 0 0 apath)
+ (concatenate 'string (ucs2->string&free apath) "\\")))
+
+(defun sb!unix:posix-getcwd ()
+ (with-alien ((apath (* tchar) (make-alien tchar (1+ MAX_PATH)))
+ (afunc (function dword dword (* tchar))
+ :extern #!-sb-unicode "GetCurrentDirectoryA@..."
+ #!+sb-unicode "GetCurrentDirectoryW@..."))
+ (let ((ret (alien-funcall afunc (1+ MAX_PATH) apath)))
+ (when (zerop ret)
+ (win32-error "GetCurrentDirectory"))
+ (when (> ret (1+ MAX_PATH))
+ (free-alien apath)
+ (setf apath (make-alien tchar ret))
+ (alien-funcall afunc ret apath))
+ (ucs2->string&free apath ret))))
+
+(defun sb!unix:unix-mkdir (name mode)
+ (declare (type sb!unix:unix-pathname name)
+ (type sb!unix:unix-file-mode mode)
+ (ignore mode))
+ (let ((name-length (length name)))
+ (with-alien ((apath (* tchar) (make-alien tchar (1+ name-length))))
+ (dotimes (i name-length) (setf (deref apath i) (char-code (aref name i))))
+ (setf (deref apath name-length) 0)
+ (when
+ (zerop (alien-funcall
+ (extern-alien #!-sb-unicode "CreateDirectoryA@..."
+ #!+sb-unicode "CreateDirectoryW@..."
+ (function bool (* tchar) dword))
+ apath 0))
+ (win32-error "CreateDirectory"))
+ (values t 0))))
+
+(defun sb!unix:unix-rename (name1 name2)
+ (declare (type sb!unix:unix-pathname name1 name2))
+ (let ((name-length1 (length name1))
+ (name-length2 (length name2)))
+ (with-alien ((apath1 (* tchar) (make-alien tchar (1+ name-length1)))
+ (apath2 (* tchar) (make-alien tchar (1+ name-length2))))
+ (dotimes (i name-length1) (setf (deref apath1 i) (char-code (aref name1 i))))
+ (setf (deref apath1 name-length1) 0)
+ (dotimes (i name-length2) (setf (deref apath2 i) (char-code (aref name2 i))))
+ (setf (deref apath2 name-length2) 0)
+ (when
+ (zerop (alien-funcall
+ (extern-alien #!-sb-unicode "MoveFileA@..."
+ #!+sb-unicode "MoveFileW@..."
+ (function bool (* tchar) (* tchar)))
+ apath1 apath2))
+ (win32-error "MoveFile"))
+ (values t 0))))
+
+
+(defun sb!unix::posix-getenv (name)
+ (declare (type simple-string name))
+ (let ((name-length (length name)))
+ (with-alien ((aname (* tchar) (make-alien tchar (1+ name-length)))
+ (aenv (* tchar) (make-alien tchar default-environment-length))
+ (afunc (function dword (* tchar) (* tchar) dword)
+ :extern #!-sb-unicode "GetEnvironmentVariableA@..."
+ #!+sb-unicode "GetEnvironmentVariableW@..."))
+ (dotimes (i name-length) (setf (deref aname i) (char-code (aref name i))))
+ (setf (deref aname name-length) 0)
+ (let ((ret (alien-funcall afunc aname aenv default-environment-length)))
+ (when (> ret default-environment-length)
+ (free-alien aenv)
+ (setf aenv (make-alien tchar ret))
+ (alien-funcall afunc aname aenv ret))
+ (if (> ret 0)
+ (ucs2->string&free aenv ret)
+ nil)))))
Index: win32-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/win32-pathname.lisp,v
retrieving revision 1.1
retrieving revision 1.1.2.1
diff -u -d -r1.1 -r1.1.2.1
--- win32-pathname.lisp 6 Jan 2006 16:44:59 -0000 1.1
+++ win32-pathname.lisp 22 Apr 2006 03:08:08 -0000 1.1.2.1
@@ -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)
Index: unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.64
retrieving revision 1.64.2.1
diff -u -d -r1.64 -r1.64.2.1
--- unix.lisp 18 Jan 2006 12:57:48 -0000 1.64
+++ unix.lisp 22 Apr 2006 03:08:08 -0000 1.64.2.1
@@ -47,7 +47,7 @@
;;;; Lisp types used by syscalls
-(deftype unix-pathname () 'simple-base-string)
+(deftype unix-pathname () #!-win32 'simple-base-string #!+win32 'simple-string)
(deftype unix-fd () `(integer 0 ,most-positive-fixnum))
(deftype unix-file-mode () '(unsigned-byte 32))
@@ -134,6 +134,7 @@
;;;; hacking the Unix environment
+#!-win32
(define-alien-routine ("getenv" posix-getenv) c-string
"Return the \"value\" part of the environment string \"name=value\" which
corresponds to NAME, or NIL if there is none."
@@ -143,6 +144,7 @@
;;; Rename the file with string NAME1 to the string NAME2. NIL and an
;;; error code is returned if an error occurs.
+#!-win32
(defun unix-rename (name1 name2)
(declare (type unix-pathname name1 name2))
(void-syscall ("rename" c-string c-string) name1 name2))
@@ -312,17 +314,24 @@
;;; value is the pipe to be read from and the second is can be written
;;; to. If an error occurred the first value is NIL and the second the
;;; unix error code.
-#!-win32
-(defun unix-pipe ()
+#!-win32(defun unix-pipe ()
(with-alien ((fds (array int 2)))
(syscall ("pipe" (* int))
(values (deref fds 0) (deref fds 1))
(cast fds (* int)))))
+#!+win32(defun msvcrt-raw-pipe (fds size mode)
+ (syscall ("_pipe" (* int) int int)
+ (values (deref fds 0) (deref fds 1))
+ (cast fds (* int)) size mode))
+#!+win32(defun unix-pipe ()
+ (with-alien ((fds (array int 2)))
+ (msvcrt-raw-pipe fds 256 o_binary)))
;; Windows mkdir() doesn't take the mode argument. It's cdecl, so we could
;; actually call it passing the mode argument, but some sharp-eyed reader
;; would put five and twenty-seven together and ask us about it, so...
;; -- AB, 2005-12-27
+#!-win32
(defun unix-mkdir (name mode)
(declare (type unix-pathname name)
(type unix-file-mode mode)
@@ -341,6 +350,7 @@
;;; Return the Unix current directory as a SIMPLE-STRING, in the
;;; style returned by getcwd() (no trailing slash character).
+#!-win32
(defun posix-getcwd ()
;; This implementation relies on a BSD/Linux extension to getcwd()
;; behavior, automatically allocating memory when a null buffer
Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.80
retrieving revision 1.80.2.1
diff -u -d -r1.80 -r1.80.2.1
--- toplevel.lisp 17 Feb 2006 17:49:37 -0000 1.80
+++ toplevel.lisp 22 Apr 2006 03:08:08 -0000 1.80.2.1
@@ -360,8 +360,12 @@
(/show0 "entering TOPLEVEL-INIT")
(let (;; value of --sysinit option
(sysinit nil)
+ ;; t if --no-sysinit option given
+ (no-sysinit nil)
;; value of --userinit option
(userinit nil)
+ ;; t if --no-userinit option given
+ (no-userinit nil)
;; values of --eval options, in reverse order; and also any
;; other options (like --load) which're translated into --eval
;;
@@ -412,11 +416,17 @@
(if sysinit
(startup-error "multiple --sysinit options")
(setf sysinit (pop-option))))
+ ((string= option "--no-sysinit")
+ (pop-option)
+ (setf no-sysinit t))
((string= option "--userinit")
(pop-option)
(if userinit
(startup-error "multiple --userinit options")
(setf userinit (pop-option))))
+ ((string= option "--no-userinit")
+ (pop-option)
+ (setf no-userinit t))
((string= option "--eval")
(pop-option)
(push (pop-option) reversed-evals))
@@ -479,10 +489,20 @@
#!-win32 (probe-init-files sysinit
(init-file-name (posix-getenv "SBCL_HOME")
"sbclrc")
- "/etc/sbclrc"))
+ "/etc/sbclrc")
+ #!+win32 (probe-init-files sysinit
+ (init-file-name (posix-getenv "SBCL_HOME")
+ "sbclrc")
+ (concatenate 'string
+ (sb!win32::get-folder-path 35) ;;SB-WIN32::CSIDL_COMMON_APPDATA
+ "\\sbcl\\sbclrc")))
+
(userinit-truename
#!-win32 (probe-init-files userinit
(init-file-name (posix-getenv "HOME")
+ ".sbclrc"))
+ #!+win32 (probe-init-files userinit
+ (init-file-name (namestring (user-homedir-pathname))
".sbclrc"))))
;; This CATCH is needed for the debugger command TOPLEVEL to
@@ -502,8 +522,8 @@
;; figure out what's going on.)
(restart-case
(progn
- (process-init-file sysinit-truename)
- (process-init-file userinit-truename)
+ (unless no-sysinit (process-init-file sysinit-truename))
+ (unless no-userinit (process-init-file userinit-truename))
(process-eval-options (reverse reversed-evals)))
(abort ()
:report "Skip to toplevel READ/EVAL/PRINT loop."
Index: target-signal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-signal.lisp,v
retrieving revision 1.33
retrieving revision 1.33.4.1
diff -u -d -r1.33 -r1.33.4.1
--- target-signal.lisp 17 Oct 2005 09:18:47 -0000 1.33
+++ target-signal.lisp 22 Apr 2006 03:08:08 -0000 1.33.4.1
@@ -125,7 +125,6 @@
(define-signal-handler sigsegv-handler "segmentation violation")
#!-linux
(define-signal-handler sigsys-handler "bad argument to a system call")
-(define-signal-handler sigpipe-handler "SIGPIPE")
(defun sigalrm-handler (signal info context)
(declare (ignore signal info context))
@@ -157,7 +156,7 @@
(enable-interrupt sigsegv #'sigsegv-handler)
#!-linux
(enable-interrupt sigsys #'sigsys-handler)
- (enable-interrupt sigpipe #'sigpipe-handler)
+ (ignore-interrupt sigpipe)
(enable-interrupt sigalrm #'sigalrm-handler)
(sb!unix::reset-signal-mask)
(values))
Index: target-format.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-format.lisp,v
retrieving revision 1.29
retrieving revision 1.29.4.1
diff -u -d -r1.29 -r1.29.4.1
--- target-format.lisp 8 Nov 2005 20:31:34 -0000 1.29
+++ target-format.lisp 22 Apr 2006 03:08:08 -0000 1.29.4.1
@@ -228,12 +228,16 @@
(prin1 (next-arg) stream)
(write-char (next-arg) stream)))))
+;;; "printing" as defined in the ANSI CL glossary, which is normative.
+(defun char-printing-p (char)
+ (and (not (eql char #\Space))
+ (graphic-char-p char)))
+
(defun format-print-named-character (char stream)
- (let* ((name (char-name char)))
- (cond (name
- (write-string (string-capitalize name) stream))
- (t
- (write-char char stream)))))
+ (cond ((not (char-printing-p char))
+ (write-string (string-capitalize (char-name char)) stream))
+ (t
+ (write-char char stream))))
(def-format-interpreter #\W (colonp atsignp params)
(interpret-bind-defaults () params
Index: sharpm.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/sharpm.lisp,v
retrieving revision 1.17
retrieving revision 1.17.6.1
diff -u -d -r1.17 -r1.17.6.1
--- sharpm.lisp 14 Jul 2005 16:30:38 -0000 1.17
+++ sharpm.lisp 22 Apr 2006 03:08:08 -0000 1.17.6.1
@@ -311,14 +311,9 @@
;;;; conditional compilation: the #+ and #- readmacros
(flet ((guts (stream not-p)
- (unless (if (handler-case
- (let ((*package* *keyword-package*)
- (*read-suppress* nil))
- (featurep (read stream t nil t)))
- (reader-package-error
- (condition)
- (declare (ignore condition))
- nil))
+ (unless (if (let ((*package* *keyword-package*)
+ (*read-suppress* nil))
+ (featurep (read stream t nil t)))
(not not-p)
not-p)
(let ((*read-suppress* t))
Index: run-program.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/run-program.lisp,v
retrieving revision 1.48
retrieving revision 1.48.2.1
diff -u -d -r1.48 -r1.48.2.1
--- run-program.lisp 15 Mar 2006 04:03:26 -0000 1.48
+++ run-program.lisp 22 Apr 2006 03:08:08 -0000 1.48.2.1
@@ -45,10 +45,14 @@
;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not
;;;; visible at GENESIS time.
-(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
+(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))
;;; Convert as best we can from an SBCL representation of a Unix
;;; environment to a CMU CL representation.
@@ -92,11 +96,13 @@
;;;; Import wait3(2) from Unix.
+#-win32
(define-alien-routine ("wait3" c-wait3) sb-alien:int
(status sb-alien:int :out)
(options sb-alien:int)
(rusage sb-alien:int))
+#-win32
(defun wait3 (&optional do-not-hang check-for-stopped)
#+sb-doc
"Return any available status information on child process. "
@@ -135,11 +141,11 @@
(not (zerop (ldb (byte 1 7) status)))))))))
;;;; process control stuff
-
(defvar *active-processes* nil
#+sb-doc
"List of process structures for all active processes.")
+#-win32
(defvar *active-processes-lock*
(sb-thread:make-mutex :name "Lock for active processes."))
@@ -147,16 +153,19 @@
;;; mutex is needed. More importantly the sigchld signal handler also
;;; accesses it, that's why we need without-interrupts.
(defmacro with-active-processes-lock (() &body body)
+ #-win32
`(without-interrupts
(sb-thread:with-mutex (*active-processes-lock*)
- ,@body)))
+ ,@body))
+ #+win32
+ `(progn ,@body))
(defstruct (process (:copier nil))
pid ; PID of child process
%status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
exit-code ; either exit code or signal
core-dumped ; T if a core image was dumped
- pty ; stream to child's pty, or NIL
+ #-win32 pty ; stream to child's pty, or NIL
input ; stream to child's input, or NIL
output ; stream from child's output, or NIL
error ; stream from child's error output, or NIL
@@ -164,15 +173,13 @@
plist ; a place for clients to stash things
cookie) ; list of the number of pipes from the subproc
-
-
(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)
@@ -181,6 +188,11 @@
#+sb-doc
(setf (documentation 'process-pid 'function) "The pid of the child process.")
+#+win32
+(define-alien-routine ("GetExitCodeProcess@..." get-exit-code-process)
+ int
+ (handle unsigned) (exit-code unsigned :out))
+
(defun process-status (process)
#+sb-doc
"Return the current status of PROCESS. The result is one of :RUNNING,
@@ -223,9 +235,9 @@
(defun process-wait (process &optional check-for-stopped)
#+sb-doc
- "Wait for PROCESS to quit running for some reason.
- When CHECK-FOR-STOPPED is T, also returns when PROCESS is
- stopped. Returns PROCESS."
+ "Wait for PROCESS to quit running for some reason. When
+CHECK-FOR-STOPPED is T, also returns when PROCESS is stopped. Returns
+PROCESS."
(loop
(case (process-status process)
(:running)
@@ -238,7 +250,7 @@
(sb-sys:serve-all-events 1))
process)
-#-hpux
+#-(or hpux win32)
;;; Find the current foreground process group id.
(defun find-current-foreground-process (proc)
(with-alien ((result sb-alien:int))
@@ -252,6 +264,7 @@
result))
(process-pid proc))
+#-win32
(defun process-kill (process signal &optional (whom :pid))
#+sb-doc
"Hand SIGNAL to PROCESS. If WHOM is :PID, use the kill Unix system call. If
@@ -300,40 +313,68 @@
(defun process-close (process)
#+sb-doc
- "Close all streams connected to PROCESS and stop maintaining the status slot."
+ "Close all streams connected to PROCESS and stop maintaining the
+status slot."
(macrolet ((frob (stream abort)
`(when ,stream (close ,stream :abort ,abort))))
- (frob (process-pty process) t) ; Don't FLUSH-OUTPUT to dead process, ..
- (frob (process-input process) t) ; .. 'cause it will generate SIGPIPE.
+ #-win32
+ (frob (process-pty process) t) ; Don't FLUSH-OUTPUT to dead process,
+ (frob (process-input process) t) ; .. 'cause it will generate SIGPIPE.
(frob (process-output process) nil)
- (frob (process-error process) nil))
+ (frob (process-error process) nil))
+ ;; FIXME: Given that the status-slot is no longer updated,
+ ;; maybe it should be set to :CLOSED, or similar?
(with-active-processes-lock ()
(setf *active-processes* (delete process *active-processes*)))
process)
;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes
+#-win32
(defun sigchld-handler (ignore1 ignore2 ignore3)
(declare (ignore ignore1 ignore2 ignore3))
(get-processes-status-changes))
(defun get-processes-status-changes ()
+ #-win32
(loop
- (multiple-value-bind (pid what code core)
- (wait3 t t)
- (unless pid
- (return))
- (let ((proc (with-active-processes-lock ()
- (find pid *active-processes* :key #'process-pid))))
- (when proc
- (setf (process-%status proc) what)
- (setf (process-exit-code proc) code)
- (setf (process-core-dumped proc) core)
- (when (process-status-hook proc)
- (funcall (process-status-hook proc) proc))
- (when (position what #(:exited :signaled))
- (with-active-processes-lock ()
- (setf *active-processes*
- (delete proc *active-processes*)))))))))
+ (multiple-value-bind (pid what code core)
+ (wait3 t t)
+ (unless pid
+ (return))
+ (let ((proc (with-active-processes-lock ()
+ (find pid *active-processes* :key #'process-pid))))
+ (when proc
+ (setf (process-%status proc) what)
+ (setf (process-exit-code proc) code)
+ (setf (process-core-dumped proc) core)
+ (when (process-status-hook proc)
+ (funcall (process-status-hook proc) proc))
+ (when (position what #(:exited :signaled))
+ (with-active-processes-lock ()
+ (setf *active-processes*
+ (delete proc *active-processes*))))))))
+ #+win32
+ (let (exited)
+ (with-active-processes-lock ()
+ (setf *active-processes*
+ (delete-if (lambda (proc)
+ (multiple-value-bind (ok code)
+ (get-exit-code-process (process-pid proc))
+ (when (and (plusp ok) (/= code 259))
+ (setf (process-%status proc) :exited
+ (process-exit-code proc) code)
+ (when (process-status-hook proc)
+ (push proc exited))
+ t)))
+ *active-processes*)))
+ ;; Can't call the hooks before all the processes have been deal
+ ;; with, as calling a hook may cause re-entry to
+ ;; GET-PROCESS-STATUS-CHANGES. That may be OK when using wait3,
+ ;; but in the Windows implementation is would be deeply bad.
+ (dolist (proc exited)
+ (let ((hook (process-status-hook proc)))
+ (when hook
+ (funcall hook proc))))))
;;;; RUN-PROGRAM and close friends
@@ -344,11 +385,13 @@
(defvar *close-in-parent* nil)
;;; list of handlers installed by RUN-PROGRAM
+#-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 ()
(dolist (char '(#\p #\q))
(dotimes (digit 16)
@@ -369,6 +412,7 @@
(sb-unix:unix-close master-fd))))))
(error "could not find a pty"))
+#-win32
(defun open-pty (pty cookie)
(when pty
(multiple-value-bind
@@ -439,6 +483,7 @@
,@body)
(sb-sys:deallocate-system-memory ,sap ,size)))))
+#-win32
(sb-alien:define-alien-routine spawn sb-alien:int
(program sb-alien:c-string)
(argv (* sb-alien:c-string))
@@ -448,30 +493,41 @@
(stdout sb-alien:int)
(stderr sb-alien:int))
+#+win32
+(sb-alien:define-alien-routine spawn sb-win32::handle
+ (program sb-alien:c-string)
+ (argv (* sb-alien:c-string))
+ (stdin sb-alien:int)
+ (stdout sb-alien:int)
+ (stderr sb-alien:int)
+ (wait sb-alien:int))
+
;;; Is UNIX-FILENAME the name of a file that we can execute?
(defun unix-filename-is-executable-p (unix-filename)
- (declare (type simple-string unix-filename))
- (setf unix-filename (coerce unix-filename 'base-string))
- (values (and (eq (sb-unix:unix-file-kind unix-filename) :file)
- (sb-unix:unix-access unix-filename sb-unix:x_ok))))
+ (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 #\: 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 (and fullpath
- (unix-filename-is-executable-p (namestring fullpath)))
- 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
@@ -516,6 +572,8 @@
;;;
;;; 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
&key
(env nil env-p)
@@ -534,14 +592,14 @@
(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):
@@ -609,7 +667,6 @@
: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.
@@ -629,9 +686,8 @@
(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))
@@ -686,6 +742,127 @@
(process-wait proc))
proc))
+#+win32
+(defun run-program (program args
+ &key
+ (wait t)
+ search
+ input
+ if-input-does-not-exist
+ output
+ (if-output-exists :error)
+ (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 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
+ Look for PROGRAM in each of the directories along the $PATH
+ environment variable. Otherwise an absolute pathname is required.
+ (See also FIND-EXECUTABLE-IN-SEARCH-PATH)
+ :WAIT
+ If non-NIL (default), wait until the created process finishes. If
+ NIL, continue running Lisp until the program finishes.
+ :INPUT
+ Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
+ input for the current process is inherited. If NIL, /dev/null
+ is used. If a pathname, the file so specified is used. If a stream,
+ all the input is read from that stream and send to the subprocess. If
+ :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
+ its output to the process. Defaults to NIL.
+ :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
+ can be one of:
+ :ERROR to generate an error
+ :CREATE to create an empty file
+ NIL (the default) to return NIL from RUN-PROGRAM
+ :OUTPUT
+ Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
+ output for the current process is inherited. If NIL, /dev/null
+ is used. If a pathname, the file so specified is used. If a stream,
+ all the output from the process is written to this stream. If
+ :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
+ be read to get the output. Defaults to NIL.
+ :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
+ can be one of:
+ :ERROR (the default) to generate an error
+ :SUPERSEDE to supersede the file with output from the program
+ :APPEND to append output from the program to the file
+ NIL to return NIL from RUN-PROGRAM, without doing anything
+ :ERROR and :IF-ERROR-EXISTS
+ Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be
+ specified as :OUTPUT in which case all error output is routed to the
+ same place as normal output.
+ :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
+ ;; communicate cleanup info.
+ *close-on-error*
+ *close-in-parent*
+ ;; Establish PROC at this level so that we can return it.
+ proc
+ ;; It's friendly to allow the caller to pass any string
+ ;; designator, but internally we'd like SIMPLE-STRINGs.
+ (simple-args (mapcar (lambda (x) (coerce x 'simple-string)) args)))
+ (unwind-protect
+ (let ((pfile
+ (if search
+ (find-executable-in-search-path program)
+ (unix-namestring program)))
+ (cookie (list 0)))
+ (unless pfile
+ (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
+ :if-does-not-exist if-input-does-not-exist)
+ (multiple-value-bind (stdout output-stream)
+ (get-descriptor-for output cookie
+ :direction :output
+ :if-exists if-output-exists)
+ (multiple-value-bind (stderr error-stream)
+ (if (eq error :output)
+ (values stdout output-stream)
+ (get-descriptor-for error cookie
+ :direction :output
+ :if-exists if-error-exists))
+ (with-c-strvec (args-vec simple-args)
+ (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
+ (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))))))))))
+ ;; FIXME: this should probably use PROCESS-WAIT instead instead
+ ;; of special argument to SPAWN.
+ (unless wait
+ (push proc *active-processes*))
+ (when (and wait status-hook)
+ (funcall status-hook proc))
+ proc))
+
;;; Install a handler for any input that shows up on the file
;;; descriptor. The handler reads the data and writes it to the
;;; stream.
@@ -720,9 +897,10 @@
(sb-unix:unix-read descriptor
(alien-sap buf)
256)
- (cond ((or (and (null count)
- (eql errno sb-unix:eio))
- (eql count 0))
+ (cond (#-win32(or (and (null count)
+ (eql errno sb-unix:eio))
+ (eql count 0))
+ #+win32(<= count 0)
(sb-sys:remove-fd-handler handler)
(setf handler nil)
(decf (car cookie))
@@ -759,7 +937,8 @@
;; Use /dev/null.
(multiple-value-bind
(fd errno)
- (sb-unix:unix-open #.(coerce "/dev/null" 'base-string)
+ (sb-unix:unix-open #-win32 #.(coerce "/dev/null" 'base-string)
+ #+win32 #.(coerce "nul" 'base-string)
(case direction
(:input sb-unix:o_rdonly)
(:output sb-unix:o_wronly)
@@ -813,7 +992,8 @@
(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
Index: reader.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/reader.lisp,v
retrieving revision 1.47
retrieving revision 1.47.4.1
diff -u -d -r1.47 -r1.47.4.1
--- reader.lisp 10 Aug 2005 07:57:33 -0000 1.47
+++ reader.lisp 22 Apr 2006 03:08:08 -0000 1.47.4.1
@@ -215,12 +215,11 @@
really-to-readtable))
(defun set-syntax-from-char (to-char from-char &optional
- (to-readtable *readtable*)
- (from-readtable ()))
+ (to-readtable *readtable*) (from-readtable ()))
#!+sb-doc
- "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the
- optional readtable (defaults to the current readtable). The
- FROM-TABLE defaults to the standard Lisp readtable when NIL."
+ "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the optional
+readtable (defaults to the current readtable). The FROM-TABLE defaults to the
+standard Lisp readtable when NIL."
(let ((really-from-readtable (or from-readtable *standard-readtable*)))
(let ((att (get-cat-entry from-char really-from-readtable))
(mac (get-raw-cmt-entry from-char really-from-readtable))
Index: pred.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/pred.lisp,v
retrieving revision 1.22.2.1
retrieving revision 1.22.2.2
diff -u -d -r1.22.2.1 -r1.22.2.2
--- pred.lisp 21 Mar 2006 19:27:57 -0000 1.22.2.1
+++ pred.lisp 22 Apr 2006 03:08:08 -0000 1.22.2.2
@@ -21,7 +21,8 @@
(defun vector-t-p (x)
(or (simple-vector-p x)
(and (complex-vector-p x)
- (simple-vector-p (%array-data-vector x)))))
+ (do ((data (%array-data-vector x) (%array-data-vector data)))
+ ((not (array-header-p data)) (simple-vector-p data))))))
;;;; primitive predicates. These must be supported directly by the
;;;; compiler.
Index: octets.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/octets.lisp,v
retrieving revision 1.12
retrieving revision 1.12.2.1
diff -u -d -r1.12 -r1.12.2.1
--- octets.lisp 21 Mar 2006 15:51:51 -0000 1.12
+++ octets.lisp 22 Apr 2006 03:08:08 -0000 1.12.2.1
@@ -649,7 +649,7 @@
"LATIN-1")
"KEYWORD")
#!+win32
- #!+sb-unicode (sb!win32::ansi-cp)
+ #!+sb-unicode (sb!win32::ansi-codepage)
#!-sb-unicode :LATIN-1))
(/show0 "cold-printing defaulted external-format:")
#!+sb-show
Index: late-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v
retrieving revision 1.126
retrieving revision 1.126.2.1
diff -u -d -r1.126 -r1.126.2.1
--- late-type.lisp 8 Mar 2006 18:49:55 -0000 1.126
+++ late-type.lisp 22 Apr 2006 03:08:08 -0000 1.126.2.1
@@ -1155,6 +1155,12 @@
;; those types can be other types in disguise. So we'd
;; better delegate.
(invoke-complex-subtypep-arg1-method type1 type2))
+ ((and (or (eq type2 *instance-type*)
+ (eq type2 *funcallable-instance-type*))
+ (member-type-p type1))
+ ;; member types can be subtypep INSTANCE and
+ ;; FUNCALLABLE-INSTANCE in surprising ways.
+ (invoke-complex-subtypep-arg1-method type1 type2))
((and (eq type2 *instance-type*) (classoid-p type1))
(if (member type1 *non-instance-classoid-types* :key #'find-classoid)
(values nil t)
@@ -1206,7 +1212,8 @@
type1
nil)
*empty-type*)
- (if (type-might-contain-other-types-p type1)
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
nil
*empty-type*)))
((eq type2 *funcallable-instance-type*)
@@ -1221,7 +1228,8 @@
nil))
(if (fun-type-p type1)
nil
- (if (type-might-contain-other-types-p type1)
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
nil
*empty-type*))))
(t (hierarchical-intersection2 type1 type2))))
Index: irrat.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/irrat.lisp,v
retrieving revision 1.31
retrieving revision 1.31.2.1
diff -u -d -r1.31 -r1.31.2.1
--- irrat.lisp 3 Jan 2006 09:52:38 -0000 1.31
+++ irrat.lisp 22 Apr 2006 03:08:08 -0000 1.31.2.1
@@ -46,8 +46,11 @@
`(defun ,name ,ll (,name ,@ll))))
(def %atan2 (x y))
(def %atan (x))
+ (def %tan (x))
(def %tan-quick (x))
+ (def %cos (x))
(def %cos-quick (x))
+ (def %sin (x))
(def %sin-quick (x))
(def %sqrt (x))
(def %log (x))
Index: filesys.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/filesys.lisp,v
retrieving revision 1.55
retrieving revision 1.55.2.1
diff -u -d -r1.55 -r1.55.2.1
--- filesys.lisp 6 Jan 2006 16:44:59 -0000 1.55
+++ filesys.lisp 22 Apr 2006 03:08:08 -0000 1.55.2.1
@@ -559,7 +559,17 @@
(defun user-homedir-pathname (&optional host)
"Return the home directory of the user as a pathname."
(declare (ignore host))
- (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid))))
+ #!-win32
+ (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid)))
+ #!+win32
+ (pathname (if (posix-getenv "HOME")
+ (let* ((path (posix-getenv "HOME"))
+ (last-char (char path (1- (length path)))))
+ (if (or (char= last-char #\/)
+ (char= last-char #\\))
+ path
+ (concatenate 'string path "/")))
+ (sb!win32::get-folder-path 40)))) ;;SB-WIN32::CSIDL_PROFILE
(defun file-write-date (file)
#!+sb-doc
Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.98
retrieving revision 1.98.2.1
diff -u -d -r1.98 -r1.98.2.1
--- fd-stream.lisp 15 Mar 2006 17:48:26 -0000 1.98
+++ fd-stream.lisp 22 Apr 2006 03:08:08 -0000 1.98.2.1
@@ -1582,33 +1582,36 @@
(declare (ignore arg2))
(case operation
(:listen
- (or (not (eql (fd-stream-ibuf-head fd-stream)
- (fd-stream-ibuf-tail fd-stream)))
- (fd-stream-listen fd-stream)
- #!+win32
- (setf (fd-stream-listen fd-stream)
- (sb!win32:fd-listen (fd-stream-fd fd-stream)))
- #!-win32
- (setf (fd-stream-listen fd-stream)
- (if (sysread-may-block-p fd-stream)
- nil
- ;; select(2) and CL:LISTEN have slightly different
- ;; semantics. The former returns that an FD is
- ;; readable when a read operation wouldn't block.
- ;; That includes EOF. However, LISTEN must return
- ;; NIL at EOF.
- (progn (catch 'eof-input-catcher
- ;; r-b/f too calls select, but it shouldn't
- ;; block as long as read can return once w/o
- ;; blocking
- (refill-buffer/fd fd-stream))
- ;; If REFILL-BUFFER/FD set the FD-STREAM-LISTEN
- ;; slot to a non-nil value (i.e. :EOF), keep
- ;; that value.
- (or (fd-stream-listen fd-stream)
- ;; Otherwise we have data -> set the slot
- ;; to T.
- t))))))
+ (labels ((do-listen ()
+ (or (not (eql (fd-stream-ibuf-head fd-stream)
+ (fd-stream-ibuf-tail fd-stream)))
+ (fd-stream-listen fd-stream)
+ #!+win32
+ (sb!win32:fd-listen (fd-stream-fd fd-stream))
+ #!-win32
+ ;; If the read can block, LISTEN will certainly return NIL.
+ (if (sysread-may-block-p fd-stream)
+ nil
+ ;; Otherwise select(2) and CL:LISTEN have slightly
+ ;; different semantics. The former returns that an FD
+ ;; is readable when a read operation wouldn't block.
+ ;; That includes EOF. However, LISTEN must return NIL
+ ;; at EOF.
+ (progn (catch 'eof-input-catcher
+ ;; r-b/f too calls select, but it shouldn't
+ ;; block as long as read can return once w/o
+ ;; blocking
+ (refill-buffer/fd fd-stream))
+ ;; At this point either IBUF-HEAD != IBUF-TAIL
+ ;; and FD-STREAM-LISTEN is NIL, in which case
+ ;; we should return T, or IBUF-HEAD ==
+ ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in
+ ;; which case we should return :EOF for this
+ ;; call and all future LISTEN call on this stream.
+ ;; Call ourselves again to determine which case
+ ;; applies.
+ (do-listen))))))
+ (do-listen)))
(:unread
(setf (fd-stream-unread fd-stream) arg1)
(setf (fd-stream-listen fd-stream) t))
@@ -2120,11 +2123,14 @@
(setf *available-buffers* nil)
(with-output-to-string (*error-output*)
(setf *stdin*
- (make-fd-stream 0 :name "standard input" :input t :buffering :line))
+ (make-fd-stream 0 :name "standard input" :input t :buffering :line
+ #!+win32 :external-format #!+win32 (sb!win32::console-input-codepage)))
(setf *stdout*
- (make-fd-stream 1 :name "standard output" :output t :buffering :line))
+ (make-fd-stream 1 :name "standard output" :output t :buffering :line
+ #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
(setf *stderr*
- (make-fd-stream 2 :name "standard error" :output t :buffering :line))
+ (make-fd-stream 2 :name "standard error" :output t :buffering :line
+ #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
(let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
(tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
(if tty
Index: eval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/eval.lisp,v
retrieving revision 1.34
retrieving revision 1.34.6.1
diff -u -d -r1.34 -r1.34.6.1
--- eval.lisp 14 Jul 2005 16:30:33 -0000 1.34
+++ eval.lisp 22 Apr 2006 03:08:08 -0000 1.34.6.1
@@ -70,7 +70,8 @@
(sb!c::process-decls decls
vars
nil
- :lexenv lexenv))))
+ :lexenv lexenv
+ :context :eval))))
(eval-progn-body body lexenv))))
(defun eval (original-exp)
@@ -79,6 +80,16 @@
result or results."
(eval-in-lexenv original-exp (make-null-lexenv)))
+;;;; EVAL-ERROR
+;;;;
+;;;; Analogous to COMPILER-ERROR, but simpler.
+
+(define-condition eval-error (encapsulated-condition) ())
+
+(defun eval-error (condition)
+ (signal 'eval-error :condition condition)
+ (bug "Unhandled EVAL-ERROR"))
+
;;; Pick off a few easy cases, and the various top level EVAL-WHEN
;;; magical cases, and call %EVAL for the rest.
(defun eval-in-lexenv (original-exp lexenv)
@@ -98,125 +109,138 @@
;; error straight away.
(invoke-restart 'sb!c::signal-error)))))
(let ((exp (macroexpand original-exp lexenv)))
- (typecase exp
- (symbol
- (ecase (info :variable :kind exp)
- (:constant
- (values (info :variable :constant-value exp)))
- ((:special :global)
- (symbol-value exp))
- ;; FIXME: This special case here is a symptom of non-ANSI
- ;; weirdness in SBCL's ALIEN implementation, which could
- ;; cause problems for e.g. code walkers. It'd probably be
- ;; good to ANSIfy it by making alien variable accessors
- ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
- ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
- ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
- ;; be retained for compatibility, it can be implemented
- ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
- ;; happy.
- (:alien
- (%eval original-exp lexenv))))
- (list
- (let ((name (first exp))
- (n-args (1- (length exp))))
- (case name
- ((function)
- (unless (= n-args 1)
- (error "wrong number of args to FUNCTION:~% ~S" exp))
- (let ((name (second exp)))
- (if (and (legal-fun-name-p name)
- (not (consp (let ((sb!c:*lexenv* lexenv))
- (sb!c:lexenv-find name funs)))))
- (%coerce-name-to-fun name)
- (%eval original-exp lexenv))))
- ((quote)
- (unless (= n-args 1)
- (error "wrong number of args to QUOTE:~% ~S" exp))
- (second exp))
- (setq
- (unless (evenp n-args)
- (error "odd number of args to SETQ:~% ~S" exp))
- (unless (zerop n-args)
- (do ((name (cdr exp) (cddr name)))
- ((null name)
- (do ((args (cdr exp) (cddr args)))
- ((null (cddr args))
- ;; We duplicate the call to SET so that the
- ;; correct value gets returned.
- (set (first args) (eval-in-lexenv (second args) lexenv)))
- (set (first args) (eval-in-lexenv (second args) lexenv))))
- (let ((symbol (first name)))
- (case (info :variable :kind symbol)
- (:special)
- (t (return (%eval original-exp lexenv))))
- (unless (type= (info :variable :type symbol)
- *universal-type*)
- ;; let the compiler deal with type checking
- (return (%eval original-exp lexenv)))))))
- ((progn)
- (eval-progn-body (rest exp) lexenv))
- ((eval-when)
- ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
- ;; instead of PROGRAM-ERROR when there's something wrong
- ;; with the syntax here (e.g. missing SITUATIONS). This
- ;; could be fixed by hand-crafting clauses to catch and
- ;; report each possibility, but it would probably be
- ;; cleaner to write a new macro
- ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
- ;; DESTRUCTURING-BIND and promotes any mismatch to
- ;; PROGRAM-ERROR, then to use it here and in (probably
- ;; dozens of) other places where the same problem
- ;; arises.
- (destructuring-bind (eval-when situations &rest body) exp
- (declare (ignore eval-when))
- (multiple-value-bind (ct lt e)
- (sb!c:parse-eval-when-situations situations)
- ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
- ;; the situation :EXECUTE (or EVAL) controls whether
- ;; evaluation occurs for other EVAL-WHEN forms; that
- ;; is, those that are not top level forms, or those
- ;; in code processed by EVAL or COMPILE. If the
- ;; :EXECUTE situation is specified in such a form,
- ;; then the body forms are processed as an implicit
- ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
- (declare (ignore ct lt))
- (when e
- (eval-progn-body body lexenv)))))
- ((locally)
- (eval-locally exp lexenv))
- ((macrolet)
- (destructuring-bind (definitions &rest body)
- (rest exp)
- (let ((lexenv
- (let ((sb!c:*lexenv* lexenv))
- (sb!c::funcall-in-macrolet-lexenv
- definitions
- (lambda (&key funs)
- (declare (ignore funs))
- sb!c:*lexenv*)
- :eval))))
- (eval-locally `(locally ,@body) lexenv))))
- ((symbol-macrolet)
- (destructuring-bind (definitions &rest body) (rest exp)
- (multiple-value-bind (lexenv vars)
- (let ((sb!c:*lexenv* lexenv))
- (sb!c::funcall-in-symbol-macrolet-lexenv
- definitions
- (lambda (&key vars)
- (values sb!c:*lexenv* vars))
- :eval))
- (eval-locally `(locally ,@body) lexenv :vars vars))))
- (t
- (if (and (symbolp name)
- (eq (info :function :kind name) :function))
- (collect ((args))
- (dolist (arg (rest exp))
- (args (eval-in-lexenv arg lexenv)))
- (apply (symbol-function name) (args)))
- (%eval exp lexenv))))))
- (t
- exp)))))
+ (handler-bind ((eval-error
+ (lambda (condition)
+ (error 'interpreted-program-error
+ :condition (encapsulated-condition condition)
+ :form exp))))
+ (typecase exp
+ (symbol
+ (ecase (info :variable :kind exp)
+ (:constant
+ (values (info :variable :constant-value exp)))
+ ((:special :global)
+ (symbol-value exp))
+ ;; FIXME: This special case here is a symptom of non-ANSI
+ ;; weirdness in SBCL's ALIEN implementation, which could
+ ;; cause problems for e.g. code walkers. It'd probably be
+ ;; good to ANSIfy it by making alien variable accessors
+ ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
+ ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
+ ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
+ ;; be retained for compatibility, it can be implemented
+ ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
+ ;; happy.
+ (:alien
+ (%eval original-exp lexenv))))
+ (list
+ (let ((name (first exp))
+ (n-args (1- (length exp))))
+ (case name
+ ((function)
+ (unless (= n-args 1)
+ (error "wrong number of args to FUNCTION:~% ~S" exp))
+ (let ((name (second exp)))
+ (if (and (legal-fun-name-p name)
+ (not (consp (let ((sb!c:*lexenv* lexenv))
+ (sb!c:lexenv-find name funs)))))
+ (%coerce-name-to-fun name)
+ (%eval original-exp lexenv))))
+ ((quote)
+ (unless (= n-args 1)
+ (error "wrong number of args to QUOTE:~% ~S" exp))
+ (second exp))
+ (setq
+ (unless (evenp n-args)
+ (error "odd number of args to SETQ:~% ~S" exp))
+ (unless (zerop n-args)
+ (do ((name (cdr exp) (cddr name)))
+ ((null name)
+ (do ((args (cdr exp) (cddr args)))
+ ((null (cddr args))
+ ;; We duplicate the call to SET so that the
+ ;; correct value gets returned.
+ (set (first args)
+ (eval-in-lexenv (second args) lexenv)))
+ (set (first args)
+ (eval-in-lexenv (second args) lexenv))))
+ (let ((symbol (first name)))
+ (case (info :variable :kind symbol)
+ (:special)
+ (t (return (%eval original-exp lexenv))))
+ (unless (type= (info :variable :type symbol)
+ *universal-type*)
+ ;; let the compiler deal with type checking
+ (return (%eval original-exp lexenv)))))))
+ ((progn)
+ (eval-progn-body (rest exp) lexenv))
+ ((eval-when)
+ ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
+ ;; instead of PROGRAM-ERROR when there's something wrong
+ ;; with the syntax here (e.g. missing SITUATIONS). This
+ ;; could be fixed by hand-crafting clauses to catch and
+ ;; report each possibility, but it would probably be
+ ;; cleaner to write a new macro
+ ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
+ ;; DESTRUCTURING-BIND and promotes any mismatch to
+ ;; PROGRAM-ERROR, then to use it here and in (probably
+ ;; dozens of) other places where the same problem
+ ;; arises.
+ (destructuring-bind (eval-when situations &rest body) exp
+ (declare (ignore eval-when))
+ (multiple-value-bind (ct lt e)
+ (sb!c:parse-eval-when-situations situations)
+ ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
+ ;; the situation :EXECUTE (or EVAL) controls whether
+ ;; evaluation occurs for other EVAL-WHEN forms; that
+ ;; is, those that are not top level forms, or those
+ ;; in code processed by EVAL or COMPILE. If the
+ ;; :EXECUTE situation is specified in such a form,
+ ;; then the body forms are processed as an implicit
+ ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
+ (declare (ignore ct lt))
+ (when e
+ (eval-progn-body body lexenv)))))
+ ((locally)
+ (eval-locally exp lexenv))
+ ((macrolet)
+ (destructuring-bind (definitions &rest body)
+ (rest exp)
+ (let ((lexenv
+ (let ((sb!c:*lexenv* lexenv))
+ (sb!c::funcall-in-macrolet-lexenv
+ definitions
+ (lambda (&key funs)
+ (declare (ignore funs))
+ sb!c:*lexenv*)
+ :eval))))
+ (eval-locally `(locally ,@body) lexenv))))
+ ((symbol-macrolet)
+ (destructuring-bind (definitions &rest body) (rest exp)
+ (multiple-value-bind (lexenv vars)
+ (let ((sb!c:*lexenv* lexenv))
+ (sb!c::funcall-in-symbol-macrolet-lexenv
+ definitions
+ (lambda (&key vars)
+ (values sb!c:*lexenv* vars))
+ :eval))
+ (eval-locally `(locally ,@body) lexenv :vars vars))))
+ ((if)
+ (destructuring-bind (test then &optional else) (rest exp)
+ (eval-in-lexenv (if (eval-in-lexenv test lexenv)
+ then
+ else)
+ lexenv)))
+ (t
+ (if (and (symbolp name)
+ (eq (info :function :kind name) :function))
+ (collect ((args))
+ (dolist (arg (rest exp))
+ (args (eval-in-lexenv arg lexenv)))
+ (apply (symbol-function name) (args)))
+ (%eval exp lexenv))))))
+ (t
+ exp))))))
;;; miscellaneous full function definitions of things which are
;;; ordinarily handled magically by the compiler
Index: error.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/error.lisp,v
retrieving revision 1.25
retrieving revision 1.25.6.1
diff -u -d -r1.25 -r1.25.6.1
--- error.lisp 14 Jul 2005 16:30:33 -0000 1.25
+++ error.lisp 22 Apr 2006 03:08:08 -0000 1.25.6.1
@@ -77,10 +77,21 @@
(:report (lambda (condition stream)
(format stream "Execution of a form compiled with errors.~%~
Form:~% ~A~%~
- Compile-time-error:~% ~A"
+ Compile-time error:~% ~A"
(program-error-source condition)
(program-error-message condition)))))
+(define-condition interpreted-program-error
+ (program-error encapsulated-condition)
+ ;; Unlike COMPILED-PROGRAM-ERROR, we don't need to dump these, so
+ ;; storing the original condition and form is OK.
+ ((form :initarg :form :reader program-error-form))
+ (:report (lambda (condition stream)
+ (format stream "~&Evaluation of~% ~S~%~
+ caused error:~% ~A~%"
+ (program-error-form condition)
+ (encapsulated-condition condition)))))
+
(define-condition simple-control-error (simple-condition control-error) ())
(define-condition simple-file-error (simple-condition file-error) ())
(define-condition simple-program-error (simple-condition program-error) ())
Index: early-package.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-package.lisp,v
retrieving revision 1.4
retrieving revision 1.4.6.1
diff -u -d -r1.4 -r1.4.6.1
--- early-package.lisp 14 Jul 2005 16:30:32 -0000 1.4
+++ early-package.lisp 22 Apr 2006 03:08:08 -0000 1.4.6.1
@@ -53,18 +53,20 @@
(when ,topmost
(setf *ignored-package-locks* :invalid)))))))
-(defun compiler-assert-symbol-home-package-unlocked (symbol control)
+(defun program-assert-symbol-home-package-unlocked (context symbol control)
#!-sb-package-locks
- (declare (ignore symbol control))
+ (declare (ignore context symbol control))
#!+sb-package-locks
- (flet ((resignal (condition)
- ;; Signal the condition to give user defined handlers a chance,
- ;; if they decline convert to compiler-error.
- (signal condition)
- (sb!c:compiler-error condition)))
- (handler-bind ((package-lock-violation #'resignal))
- (with-single-package-locked-error ()
- (assert-symbol-home-package-unlocked symbol control)))))
+ (handler-bind ((package-lock-violation
+ (lambda (condition)
+ (ecase context
+ (:compile
+ (warn "Compile-time package lock violation:~% ~A"
+ condition)
+ (sb!c:compiler-error condition))
+ (:eval
+ (eval-error condition))))))
+ (with-single-package-locked-error (:symbol symbol control))))
(defmacro without-package-locks (&body body)
#!+sb-doc
Index: early-fasl.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-fasl.lisp,v
retrieving revision 1.63
retrieving revision 1.63.2.1
diff -u -d -r1.63 -r1.63.2.1
--- early-fasl.lisp 4 Mar 2006 19:58:26 -0000 1.63
+++ early-fasl.lisp 22 Apr 2006 03:08:08 -0000 1.63.2.1
@@ -76,7 +76,7 @@
;;; versions which break binary compatibility. But it certainly should
;;; be incremented for release versions which break binary
;;; compatibility.
-(def!constant +fasl-file-version+ 64)
+(def!constant +fasl-file-version+ 65)
;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so)
;;; 38: (2003-01-05) changed names of internal SORT machinery
;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to
@@ -134,6 +134,7 @@
;;; trap information size on RISCy platforms.
;;; 64: (2006-03-24) New calling convention for unknown-values on x86 and
;;; x86-64. Also (belatedly) PPC/gencgc, including :gencgc on FPAFF.
+;;; 65: (2006-04-11) Package locking interface changed.
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
Index: defstruct.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v
retrieving revision 1.81
retrieving revision 1.81.4.1
diff -u -d -r1.81 -r1.81.4.1
--- defstruct.lisp 6 Nov 2005 08:40:31 -0000 1.81
+++ defstruct.lisp 22 Apr 2006 03:08:08 -0000 1.81.4.1
@@ -383,7 +383,10 @@
(append (typed-accessor-definitions dd)
(typed-predicate-definitions dd)
(typed-copier-definitions dd)
- (constructor-definitions dd)))
+ (constructor-definitions dd)
+ (when (dd-doc dd)
+ `((setf (fdocumentation ',(dd-name dd) 'structure)
+ ',(dd-doc dd))))))
',name)))))
(sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
Index: debug-int.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug-int.lisp,v
retrieving revision 1.101
retrieving revision 1.101.4.1
diff -u -d -r1.101 -r1.101.4.1
--- debug-int.lisp 28 Sep 2005 13:42:24 -0000 1.101
+++ debug-int.lisp 22 Apr 2006 03:08:08 -0000 1.101.4.1
@@ -3128,7 +3128,7 @@
(unless (member data *executing-breakpoint-hooks*)
(let ((*executing-breakpoint-hooks* (cons data
*executing-breakpoint-hooks*)))
- (invoke-breakpoint-hooks breakpoints component offset)))
+ (invoke-breakpoint-hooks breakpoints signal-context)))
;; At this point breakpoints may not hold the same list as
;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
;; a breakpoint deactivation. In fact, if all breakpoints were
@@ -3151,10 +3151,8 @@
#!+(and sparc solaris)
(error "BREAKPOINT-DO-DISPLACED-INST returned?")))
-(defun invoke-breakpoint-hooks (breakpoints component offset)
- (let* ((debug-fun (debug-fun-from-pc component offset))
- (frame (do ((f (top-frame) (frame-down f)))
- ((eq debug-fun (frame-debug-fun f)) f))))
+(defun invoke-breakpoint-hooks (breakpoints signal-context)
+ (let* ((frame (signal-context-frame signal-context)))
(dolist (bpt breakpoints)
(funcall (breakpoint-hook-fun bpt)
frame
@@ -3166,6 +3164,16 @@
(breakpoint-unknown-return-partner bpt)
bpt)))))
+(defun signal-context-frame (signal-context)
+ (let* ((scp
+ (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (sb!alien:sap-alien signal-context (* os-context-t))))
+ (cfp (int-sap (sb!vm:context-register scp sb!vm::cfp-offset))))
+ (compute-calling-frame cfp
+ (sb!vm:context-pc scp)
+ nil)))
+
(defun handle-fun-end-breakpoint (offset component context)
(let ((data (breakpoint-data component offset nil)))
(unless data
@@ -3186,10 +3194,7 @@
(locally
(declare (optimize (inhibit-warnings 3)))
(sb!alien:sap-alien signal-context (* os-context-t))))
- (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
- (f (top-frame) (frame-down f)))
- ((= cfp (sap-int (frame-pointer f))) f)
- (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp))))
+ (frame (signal-context-frame signal-context))
(component (breakpoint-data-component data))
(cookie (gethash component *fun-end-cookies*)))
(remhash component *fun-end-cookies*)
Index: cross-misc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cross-misc.lisp,v
retrieving revision 1.23
retrieving revision 1.23.4.1
diff -u -d -r1.23 -r1.23.4.1
--- cross-misc.lisp 9 Sep 2005 14:16:18 -0000 1.23
+++ cross-misc.lisp 22 Apr 2006 03:08:08 -0000 1.23.4.1
@@ -155,8 +155,8 @@
(declare (ignore kind thing format))
`(progn ,@body))
-(defun compiler-assert-symbol-home-package-unlocked (symbol control)
- (declare (ignore control))
+(defun program-assert-symbol-home-package-unlocked (context symbol control)
+ (declare (ignore context control))
symbol)
(defun assert-package-unlocked (package &optional control &rest args)
|