From: Christophe R. <cr...@us...> - 2006-01-03 09:52:52
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25099/src/code Modified Files: cold-init.lisp fd-stream.lisp foreign.lisp irrat.lisp octets.lisp save.lisp serve-event.lisp target-alieneval.lisp target-misc.lisp toplevel.lisp unix.lisp Added Files: target-exception.lisp win32-os.lisp Log Message: 0.9.8.7: Merge "merge candidate 1" for SBCL/Win32. ... a lot done, a lot left to do. --- NEW FILE: target-exception.lisp --- ;;;; code for handling Win32 exceptions ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!UNIX") ;;; ;;; An awful lot of this stuff is stubbed out for now. We basically ;;; only handle inbound exceptions (the local equivalent to unblockable ;;; signals), and we're only picking off the sigsegv and sigfpe traps. ;;; ;;; This file is based on target-signal.lisp, but most of that went ;;; away. Some of it might want to be put back or emulated. ;;; ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that ;;; SIGINT in --disable-debugger mode will cleanly terminate the system ;;; (by respecting the *DEBUGGER-HOOK* established in that mode). ;;; ;;; We'd like to have this work, but that would require some method of ;;; delivering a "blockable signal". Windows doesn't really have the ;;; concept, so we need to play with the threading functions to emulate ;;; it (especially since the local equivalent of SIGINT comes in on a ;;; separate thread). This is on the list for fixing later on, and will ;;; be required before we implement threads (because of stop-for-gc). ;;; ;;; This specific bit of functionality may well be implemented entirely ;;; in the runtime. #| (defun sigint-%break (format-string &rest format-arguments) (flet ((break-it () (apply #'%break 'sigint format-string format-arguments))) (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it))) |# ;;; Actual exception handler. We hit something the runtime doesn't ;;; want to or know how to deal with (that is, not a sigtrap or gc ;;; wp violation), so it calls us here. (defun sb!kernel:handle-win32-exception (context exception-record) (error "An exception occured! Context ~A, exception-record ~A." context exception-record)) ;;;; etc. ;;; CMU CL comment: ;;; Magically converted by the compiler into a break instruction. ;;; SBCL/Win32 comment: ;;; I don't know if we still need this or not. Better safe for now. (defun receive-pending-interrupt () (receive-pending-interrupt)) --- NEW FILE: win32-os.lisp --- ;;;; OS interface functions for SBCL under Win32. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!SYS") ;;; Check that target machine features are set up consistently with ;;; this file. #!-win32 (error "missing :WIN32 feature") (defun software-type () #!+sb-doc "Return a string describing the supporting software." (values "Win32")) (defvar *software-version* nil) (defun software-version () #!+sb-doc "Return a string describing version of the supporting software, or NIL if not available." nil ;; FIXME: Implement. #+nil(or *software-version* (setf *software-version* (string-trim '(#\newline) (with-output-to-string (stream) (sb!ext:run-program "/bin/uname" `("-r") :output stream)))))) (defun os-cold-init-or-reinit () ; KLUDGE: don't know what to do here (/show0 "entering win32-os.lisp OS-COLD-INIT-OR-REINIT") (setf *software-version* nil) (/show0 "setting *DEFAULT-PATHNAME-DEFAULTS*") (setf *default-pathname-defaults* ;; (temporary value, so that #'NATIVE-PATHNAME won't blow up when ;; we call it below:) (make-trivial-default-pathname) *default-pathname-defaults* ;; (final value, constructed using #'NATIVE-PATHNAME:) (native-pathname (sb!unix:posix-getcwd/))) (/show0 "leaving linux-os.lisp OS-COLD-INIT-OR-REINIT")) ;;; Return system time, user time and number of page faults. (defun get-system-info () #+nil (multiple-value-bind (err? utime stime maxrss ixrss idrss isrss minflt majflt) (sb!unix:unix-getrusage sb!unix:rusage_self) (declare (ignore maxrss ixrss idrss isrss minflt)) (unless err? ; FIXME: nonmnemonic (reversed) name for ERR? (error "Unix system call getrusage failed: ~A." (strerror utime))) (values utime stime majflt))) ;;; Return the system page size. (defun get-page-size () ;; probably should call getpagesize() ;; FIXME: Or we could just get rid of this, since the uses of it look ;; disposable. 4096) Index: cold-init.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v retrieving revision 1.60 retrieving revision 1.61 diff -u -d -r1.60 -r1.61 --- cold-init.lisp 18 Nov 2005 12:28:40 -0000 1.60 +++ cold-init.lisp 3 Jan 2006 09:52:38 -0000 1.61 @@ -218,7 +218,7 @@ (show-and-call stream-cold-init-or-reset) (show-and-call !loader-cold-init) (show-and-call !foreign-cold-init) - (show-and-call signal-cold-init-or-reinit) + #!-win32 (show-and-call signal-cold-init-or-reinit) (/show0 "enabling internal errors") (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t) @@ -290,7 +290,7 @@ (os-cold-init-or-reinit) (thread-init-or-reinit) (stream-reinit) - (signal-cold-init-or-reinit) + #!-win32 (signal-cold-init-or-reinit) (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t) ;; PRINT seems not to like x86 NPX denormal floats like ;; LEAST-NEGATIVE-SINGLE-FLOAT, so the :UNDERFLOW exceptions are Index: fd-stream.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v retrieving revision 1.91 retrieving revision 1.92 diff -u -d -r1.91 -r1.92 --- fd-stream.lisp 29 Nov 2005 13:34:35 -0000 1.91 +++ fd-stream.lisp 3 Jan 2006 09:52:38 -0000 1.92 @@ -187,7 +187,7 @@ start length) (cond ((not count) - (if (= errno sb!unix:ewouldblock) + (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32 (error "Write would have blocked, but SERVER told us to go.") (simple-stream-perror "couldn't write to ~S" stream errno))) ((eql count length) ; Hot damn, it worked. @@ -238,7 +238,7 @@ (multiple-value-bind (count errno) (sb!unix:unix-write (fd-stream-fd stream) base start length) (cond ((not count) - (if (= errno sb!unix:ewouldblock) + (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32 (output-later stream base start end reuse-sap) (simple-stream-perror "couldn't write to ~S" stream @@ -687,7 +687,7 @@ (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail)) (- buflen tail)) (cond ((null count) - (if (eql errno sb!unix:ewouldblock) + (if #!-win32 (eql errno sb!unix:ewouldblock) #!+win32 t #!-win32 (progn (unless (sb!sys:wait-until-fd-usable fd :input (fd-stream-timeout stream)) @@ -1879,6 +1879,7 @@ ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write ;;; access, since we don't want to trash unwritable files even if we ;;; technically can. We return true if we succeed in renaming. +#!-win32 (defun rename-the-old-one (namestring original) (unless (sb!unix:unix-access namestring sb!unix:w_ok) (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring)) Index: foreign.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/foreign.lisp,v retrieving revision 1.36 retrieving revision 1.37 diff -u -d -r1.36 -r1.37 --- foreign.lisp 14 Jul 2005 16:30:34 -0000 1.36 +++ foreign.lisp 3 Jan 2006 09:52:38 -0000 1.37 @@ -11,13 +11,13 @@ (in-package "SB!IMPL") -#!-(or elf mach-o) -(error "Not an ELF or Mach-O platform?") +#!-(or elf mach-o win32) +(error "Not an ELF, Mach-O, or Win32 platform?") (defun extern-alien-name (name) (handler-case #!+elf (coerce name 'base-string) - #!+mach-o (concatenate 'base-string "_" name) + #!+(or mach-o win32) (concatenate 'base-string "_" name) (error () (error "invalid external alien name: ~S" name)))) Index: irrat.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/irrat.lisp,v retrieving revision 1.30 retrieving revision 1.31 diff -u -d -r1.30 -r1.31 --- irrat.lisp 1 Dec 2005 04:16:00 -0000 1.30 +++ irrat.lisp 3 Jan 2006 09:52:38 -0000 1.31 @@ -73,16 +73,16 @@ #!-x86 (def-math-rtn "atan2" 2) (def-math-rtn "sinh" 1) (def-math-rtn "cosh" 1) -(def-math-rtn "tanh" 1) -(def-math-rtn "asinh" 1) -(def-math-rtn "acosh" 1) -(def-math-rtn "atanh" 1) +#!-win32(def-math-rtn "tanh" 1) +#!-win32(def-math-rtn "asinh" 1) +#!-win32(def-math-rtn "acosh" 1) +#!-win32(def-math-rtn "atanh" 1) ;;; exponential and logarithmic #!-x86 (def-math-rtn "exp" 1) #!-x86 (def-math-rtn "log" 1) #!-x86 (def-math-rtn "log10" 1) -(def-math-rtn "pow" 2) +#!-win32(def-math-rtn "pow" 2) #!-(or x86 x86-64) (def-math-rtn "sqrt" 1) (def-math-rtn "hypot" 2) #!-(or hpux x86) (def-math-rtn "log1p" 1) Index: octets.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/octets.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- octets.lisp 15 Oct 2005 17:36:20 -0000 1.9 +++ octets.lisp 3 Jan 2006 09:52:38 -0000 1.10 @@ -640,7 +640,7 @@ (defun default-external-format () (or *default-external-format* - (let ((external-format (intern (or (sb!alien:alien-funcall + (let ((external-format (intern (or #!-win32 (sb!alien:alien-funcall (extern-alien "nl_langinfo" (function c-string int)) Index: save.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/save.lisp,v retrieving revision 1.30 retrieving revision 1.31 diff -u -d -r1.30 -r1.31 --- save.lisp 20 Oct 2005 20:44:16 -0000 1.30 +++ save.lisp 3 Jan 2006 09:52:38 -0000 1.31 @@ -135,7 +135,7 @@ (dolist (hook *save-hooks*) (with-simple-restart (continue "Skip this save hook.") (funcall hook))) - (when (fboundp 'cancel-finalization) + #!-win32 (when (fboundp 'cancel-finalization) (cancel-finalization sb!sys:*tty*)) (profile-deinit) (debug-deinit) Index: serve-event.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/serve-event.lisp,v retrieving revision 1.12 retrieving revision 1.13 diff -u -d -r1.12 -r1.13 --- serve-event.lisp 14 Jul 2005 16:30:38 -0000 1.12 +++ serve-event.lisp 3 Jan 2006 09:52:38 -0000 1.13 @@ -310,7 +310,7 @@ (sb!alien:addr read-fds) (sb!alien:addr write-fds) nil to-sec to-usec) - + #!+win32 (declare (ignorable err)) ;; Now see what it was (if anything) (cond (value (cond ((zerop value) @@ -319,6 +319,7 @@ (funcall *periodic-polling-function*))) (t (call-fd-handler)))) + #!-win32 ((eql err sb!unix:eintr) ;; We did an interrupt. t) Index: target-alieneval.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-alieneval.lisp,v retrieving revision 1.37 retrieving revision 1.38 diff -u -d -r1.37 -r1.38 --- target-alieneval.lisp 15 Oct 2005 12:55:53 -0000 1.37 +++ target-alieneval.lisp 3 Jan 2006 09:52:38 -0000 1.38 @@ -587,6 +587,37 @@ (t (error "~S is not an alien function." alien))))) +(defun alien-funcall-stdcall (alien &rest args) + #!+sb-doc + "Call the foreign function ALIEN with the specified arguments. ALIEN's + type specifies the argument and result types." + (declare (type alien-value alien)) + (let ((type (alien-value-type alien))) + (typecase type + (alien-pointer-type + (apply #'alien-funcall-stdcall (deref alien) args)) + (alien-fun-type + (unless (= (length (alien-fun-type-arg-types type)) + (length args)) + (error "wrong number of arguments for ~S~%expected ~W, got ~W" + type + (length (alien-fun-type-arg-types type)) + (length args))) + (let ((stub (alien-fun-type-stub type))) + (unless stub + (setf stub + (let ((fun (gensym)) + (parms (make-gensym-list (length args)))) + (compile nil + `(lambda (,fun ,@parms) + (declare (optimize (sb!c::insert-step-conditions 0))) + (declare (type (alien ,type) ,fun)) + (alien-funcall-stdcall ,fun ,@parms))))) + (setf (alien-fun-type-stub type) stub)) + (apply stub alien args))) + (t + (error "~S is not an alien function." alien))))) + (defmacro define-alien-routine (name result-type &rest args &environment lexenv) Index: target-misc.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-misc.lisp,v retrieving revision 1.24 retrieving revision 1.25 diff -u -d -r1.24 -r1.25 --- target-misc.lisp 12 Oct 2005 12:35:31 -0000 1.24 +++ target-misc.lisp 3 Jan 2006 09:52:38 -0000 1.25 @@ -129,7 +129,8 @@ (defun machine-instance () #!+sb-doc "Return a string giving the name of the local machine." - (sb!unix:unix-gethostname)) + #!+win32 "some-random-windows-box" + #!-win32 (sb!unix:unix-gethostname)) (defvar *machine-version*) Index: toplevel.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v retrieving revision 1.76 retrieving revision 1.77 diff -u -d -r1.76 -r1.77 --- toplevel.lisp 16 Dec 2005 15:06:12 -0000 1.76 +++ toplevel.lisp 3 Jan 2006 09:52:38 -0000 1.77 @@ -472,7 +472,7 @@ (init-file-name (maybe-dir-name basename) (and maybe-dir-name (concatenate 'string maybe-dir-name "/" basename)))) - (let ((sysinit-truename + #!-win32 (let ((sysinit-truename (probe-init-files sysinit (init-file-name (posix-getenv "SBCL_HOME") "sbclrc") @@ -561,7 +561,7 @@ (with-simple-restart (abort "~@<Exit debugger, returning to top level.~@:>") (catch 'toplevel-catcher - (sb!unix::reset-signal-mask) + #!-win32 (sb!unix::reset-signal-mask) ;; In the event of a control-stack-exhausted-error, we ;; should have unwound enough stack by the time we get ;; here that this is now possible. Index: unix.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v retrieving revision 1.60 retrieving revision 1.61 diff -u -d -r1.60 -r1.61 --- unix.lisp 16 Dec 2005 15:06:13 -0000 1.60 +++ unix.lisp 3 Jan 2006 09:52:38 -0000 1.61 @@ -101,9 +101,36 @@ `(let (,value ,errno) (loop (multiple-value-setq (,value ,errno) ,syscall-form) - (unless (eql ,errno sb!unix:eintr) + (unless #!-win32 (eql ,errno sb!unix:eintr) #!+win32 nil (return (values ,value ,errno)))) ,@body)) + +#!+win32 +(progn + (defconstant o_rdonly 0) + (defconstant o_wronly 1) + (defconstant o_rdwr 2) + (defconstant o_creat #x100) + (defconstant o_trunc #x200) + (defconstant o_append #x008) + (defconstant o_excl #x400) + (defconstant enoent 2) + (defconstant eexist 17) + (defconstant espipe 29) + (defconstant o_binary #x8000) + (defconstant s-ifmt #xf000) + (defconstant s-ifdir #x4000) + (defconstant s-ifreg #x8000) + (define-alien-type ino-t short) + (define-alien-type time-t long) + (define-alien-type off-t long) + (define-alien-type size-t long) + (define-alien-type mode-t unsigned-short) + + ;; For stat-wrapper hack (different-type or non-existing win32 fields). + (define-alien-type nlink-t short) + (define-alien-type uid-t short) + (define-alien-type gid-t short)) ;;;; hacking the Unix environment @@ -157,7 +184,7 @@ (declare (type unix-pathname path) (type fixnum flags) (type unix-file-mode mode)) - (int-syscall ("open" c-string int int) path flags mode)) + (int-syscall ("open" c-string int int) path (logior #!+win32 o_binary flags) mode)) ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file ;;; associated with it. @@ -212,6 +239,7 @@ ;;; w_ok Write permission. ;;; x_ok Execute permission. ;;; f_ok Presence of file. +#!-win32 (defun unix-access (path mode) (declare (type unix-pathname path) (type (mod 8) mode)) @@ -275,16 +303,22 @@ ;;; 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 () (with-alien ((fds (array int 2))) (syscall ("pipe" (* int)) (values (deref fds 0) (deref fds 1)) (cast fds (* int))))) +;; 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 (defun unix-mkdir (name mode) (declare (type unix-pathname name) - (type unix-file-mode mode)) - (void-syscall ("mkdir" c-string int) name mode)) + (type unix-file-mode mode) + #!+win32 (ignore mode)) + (void-syscall ("mkdir" c-string #!-win32 int) name #!-win32 mode)) ;;; Given a C char* pointer allocated by malloc(), free it and return a ;;; corresponding Lisp string (or return NIL if the pointer is a C NULL). @@ -311,14 +345,23 @@ ;; a constant. Going the grovel_headers route doesn't seem to be ;; helpful, either, as Solaris doesn't export PATH_MAX from ;; unistd.h. - #!-(or linux openbsd freebsd netbsd sunos osf1 darwin) (,stub,) - #!+(or linux openbsd freebsd netbsd sunos osf1 darwin) - (or (newcharstar-string (alien-funcall (extern-alien "getcwd" + ;; + ;; The Win32 damage here is explained in the comment above wrap_getcwd() + ;; in src/runtime/wrap.c. Short form: We need it now, it goes away later. + ;; + ;; FIXME: The (,stub,) nastiness produces an error message about a + ;; comma not inside a backquote. This error has absolutely nothing + ;; to do with the actual meaning of the error (and little to do with + ;; its location, either). + #!-(or linux openbsd freebsd netbsd sunos osf1 darwin win32) (,stub,) + #!+(or linux openbsd freebsd netbsd sunos osf1 darwin win32) + (or (newcharstar-string (alien-funcall (extern-alien #!-win32 "getcwd" + #!+win32 "wrap_getcwd" (function (* char) (* char) size-t)) nil - #!+(or linux openbsd freebsd netbsd darwin) 0 + #!+(or linux openbsd freebsd netbsd darwin win32) 0 #!+(or sunos osf1) 1025)) (simple-perror "getcwd"))) @@ -345,9 +388,11 @@ (define-alien-routine ("getpid" unix-getpid) int) ;;; Return the real user id associated with the current process. +#!-win32 (define-alien-routine ("getuid" unix-getuid) int) ;;; Translate a user id into a login name. +#!-win32 (defun uid-username (uid) (or (newcharstar-string (alien-funcall (extern-alien "uid_username" (function (* char) int)) @@ -356,6 +401,7 @@ ;;; Return the namestring of the home directory, being careful to ;;; include a trailing #\/ +#!-win32 (defun uid-homedir (uid) (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir" (function (* char) int)) @@ -365,6 +411,7 @@ ;;; Invoke readlink(2) on the file name specified by PATH. Return ;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on ;;; failure. +#!-win32 (defun unix-readlink (path) (declare (type unix-pathname path)) (with-alien ((ptr (* char) @@ -378,6 +425,12 @@ (values (with-alien ((c-string c-string ptr)) c-string) nil) (free-alien ptr))))) +#!+win32 +;; Win32 doesn't do links, but something likes to call this anyway. +;; Something in this file, no less. But it only takes one result, so... +(defun unix-readlink (path) + (declare (ignore path)) + nil) ;;; UNIX-UNLINK accepts a name and deletes the directory entry for that ;;; name and the file if this is the last link. @@ -386,12 +439,14 @@ (void-syscall ("unlink" c-string) name)) ;;; Return the name of the host machine as a string. +#!-win32 (defun unix-gethostname () (with-alien ((buf (array char 256))) (syscall ("gethostname" (* char) int) (cast buf c-string) (cast buf (* char)) 256))) +#!-win32 (defun unix-setsid () (int-syscall ("setsid"))) @@ -400,6 +455,7 @@ ;;; UNIX-IOCTL performs a variety of operations on open i/o ;;; descriptors. See the UNIX Programmer's Manual for more ;;; information. +#!-win32 (defun unix-ioctl (fd cmd arg) (declare (type unix-fd fd) (type (signed-byte 32) cmd)) @@ -413,6 +469,7 @@ ;;; user time, and returns the seconds and microseconds as separate ;;; values. #!-sb-fluid (declaim (inline unix-fast-getrusage)) +#!-win32 (defun unix-fast-getrusage (who) (declare (values (member t) (unsigned-byte 31) (integer 0 1000000) @@ -431,6 +488,7 @@ ;;; (rusage_self) or all of the terminated child processes ;;; (rusage_children). NIL and an error number is returned if the call ;;; fails. +#!-win32 (defun unix-getrusage (who) (with-alien ((usage (struct rusage))) (syscall ("getrusage" int (* (struct rusage))) @@ -664,6 +722,7 @@ (seconds-west sb!alien:int :out) (daylight-savings-p sb!alien:boolean :out)) +#!-win32 (defun nanosleep (secs nsecs) (with-alien ((req (struct timespec)) (rem (struct timespec))) @@ -720,6 +779,7 @@ (defconstant itimer-virtual 1) (defconstant itimer-prof 2) +#!-win32 (defun unix-getitimer (which) "Unix-getitimer returns the INTERVAL and VALUE slots of one of three system timers (:real :virtual or :profile). On success, @@ -742,6 +802,7 @@ (slot (slot itv 'it-value) 'tv-usec)) which (alien-sap (addr itv)))))) +#!-win32 (defun unix-setitimer (which int-secs int-usec val-secs val-usec) " Unix-setitimer sets the INTERVAL and VALUE slots of one of three system timers (:real :virtual or :profile). A SIGALRM signal @@ -797,6 +858,7 @@ (let ((kind (logand mode s-ifmt))) (cond ((eql kind s-ifdir) :directory) ((eql kind s-ifreg) :file) + #!-win32 ((eql kind s-iflnk) :link) (t :special)))))) |