Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code x86-vm.lisp,1.30,1.30.6.1 win32.lisp,1.2,1.2.2.1 win32-pathname.lisp,1.1,1.1.2.1 unix.lisp,1.64,1.64.2.1 toplevel.lisp,1.80,1.80.2.1 target-signal.lisp,1.33,1.33.4.1 target-format.lisp,1.29,1.29.4.1 sharpm.lisp,1.17,1.17.6.1 run-program.lisp,1.48,1.48.2.1 reader.lisp,1.47,1.47.4.1 pred.lisp,1.22.2.1,1.22.2.2 octets.lisp,1.12,1.12.2.1 late-type.lisp,1.126,1.126.2.1 irrat.lisp,1.31,1.31.2.1 filesys.lisp,1.55,1.55.2.1 fd-stream.lisp,1.98,1.98.2.1 eval.lisp,1.34,1.34.6.1 error.lisp,1.25,1.25.6.1 early-package.lisp,1.4,1.4.6.1 early-fasl.lisp,1.63,1.63.2.1 defstruct.lisp,1.81,1.81.4.1 debug-int.lisp,1.101,1.101.4.1 cross-misc.lisp,1.23,1.23.4.1
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@4" 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@0" (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@0" (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@0" (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@0" (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@4" 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@28" + #!-sb-unicode "FormatMessageA@28" + (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@20" + #!+sb-unicode "SHGetFolderPathW@20" + (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@8" + #!+sb-unicode "GetCurrentDirectoryW@8")) + (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@8" + #!+sb-unicode "CreateDirectoryW@8" + (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@8" + #!+sb-unicode "MoveFileW@8" + (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@12" + #!+sb-unicode "GetEnvironmentVariableW@12")) + (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@8" 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)) - ... [truncated message content] |