From c03ebb54770cfa613d4b706a80e5be231786a5d0 Mon Sep 17 00:00:00 2001 From: Rudi Schlatte Date: Wed, 5 Apr 2006 08:47:16 +0000 Subject: [PATCH] 0.9.11.13 Merge Timothy Ritchey's win32 megapatch: * user-homedir-pathname and initfile fixes (by Yaroslav Kavenchuk) * run-program (by Mike Thomas) * sockets (Timothy Ritchey) With this patch, sbcl has been reported to run SLIME on win32. ... apologies if I got any credits wrong, the patches have been floating around quite a bit - if you contributed something in there and the NEWS entry doesn't mention you, just drop me a note and I'll update it accordingly. --- NEWS | 6 + contrib/sb-bsd-sockets/defpackage.lisp | 6 + contrib/sb-bsd-sockets/inet.lisp | 2 +- contrib/sb-bsd-sockets/misc.lisp | 10 ++ contrib/sb-bsd-sockets/name-service.lisp | 21 +++- contrib/sb-bsd-sockets/sb-bsd-sockets.asd | 29 +++-- contrib/sb-bsd-sockets/sockets.lisp | 5 + contrib/sb-bsd-sockets/sockopt.lisp | 2 +- contrib/sb-bsd-sockets/tests.lisp | 1 + src/code/filesys.lisp | 12 +- src/code/run-program.lisp | 180 +++++++++++++++++++++++++---- src/code/toplevel.lisp | 12 +- src/code/unix.lisp | 16 ++- src/code/win32.lisp | 126 ++++++++++++++++++++ src/cold/warm.lisp | 2 +- src/compiler/x86/parms.lisp | 4 +- src/runtime/run-program.c | 79 +++++++++++++ src/runtime/win32-os.c | 35 +++++- tools-for-build/grovel-headers.c | 73 ++++++++++++ version.lisp-expr | 2 +- 20 files changed, 571 insertions(+), 52 deletions(-) diff --git a/NEWS b/NEWS index 92abfb2..e6a4be0 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,11 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-0.9.12 relative to sbcl-0.9.11: + * Enhancements for sbcl running on the Windows operating system: + ** (user-homedir-pathname) and default initialization file + locations now know about the user's "Documents and Settings" + directory (thanks to Yaroslav Kavenchuk) + ** run-program is implemented (thanks to Mike Thomas) + ** sockets support (thanks to Timothy Ritchey) * new feature: command line options --no-sysinit, --no-userinit to inhibit loading the corresponding init files * bug fix: LISTEN sometimes returned T even in cases where no data was diff --git a/contrib/sb-bsd-sockets/defpackage.lisp b/contrib/sb-bsd-sockets/defpackage.lisp index f6d18b4..e431cf3 100644 --- a/contrib/sb-bsd-sockets/defpackage.lisp +++ b/contrib/sb-bsd-sockets/defpackage.lisp @@ -1,3 +1,9 @@ +#+(and sbcl win32) +(defpackage "SB-WIN32-SOCKETS-INTERNAL" + (:nicknames "WIN32SOCKINT") + (:shadow close listen) + (:use "COMMON-LISP" "SB-ALIEN" "SB-EXT" "SB-C-CALL")) + (defpackage "SB-BSD-SOCKETS-INTERNAL" (:nicknames "SOCKINT") (:shadow close listen) diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp index 5879341..e6265ed 100644 --- a/contrib/sb-bsd-sockets/inet.lisp +++ b/contrib/sb-bsd-sockets/inet.lisp @@ -42,7 +42,7 @@ using getprotobyname(2) which typically looks in NIS or /etc/protocols" ;; for extra brownie points, could return canonical protocol name ;; and aliases as extra values (let ((ent (sockint::getprotobyname name))) - (if (sb-grovel::foreign-nullp ent) + (if (sb-alien::null-alien ent) (error 'unknown-protocol :name name)) (sockint::protoent-proto ent))) diff --git a/contrib/sb-bsd-sockets/misc.lisp b/contrib/sb-bsd-sockets/misc.lisp index 21ce486..a263ca5 100644 --- a/contrib/sb-bsd-sockets/misc.lisp +++ b/contrib/sb-bsd-sockets/misc.lisp @@ -12,6 +12,7 @@ (defgeneric non-blocking-mode (socket) (:documentation "Is SOCKET in non-blocking mode?")) +#-win32 (defmethod non-blocking-mode ((socket socket)) (let ((fd (socket-file-descriptor socket))) (sb-alien:with-alien ((arg integer)) @@ -20,9 +21,13 @@ sockint::o-nonblock) 0)))) +#+win32 +(defmethod non-blocking-mode ((socket socket)) 0) + (defgeneric (setf non-blocking-mode) (non-blocking-p socket) (:documentation "Put SOCKET in non-blocking mode - or not, according to NON-BLOCKING-P")) +#-win32 (defmethod (setf non-blocking-mode) (non-blocking-p (socket socket)) (declare (optimize (speed 3))) (let* ((fd (socket-file-descriptor socket)) @@ -37,4 +42,9 @@ (socket-error "fcntl")) non-blocking-p)) +#+win32 +(defmethod (setf non-blocking-mode) (non-blocking-p (socket socket)) 0) +;; (sb-alien:with-alien ((mode (unsigned 32))) +;; (if non-blocking-p (setf mode 1)) +;; (ioctlsocket socket FIONBIO mode))) diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp index 7ae73af..d55ee8d 100644 --- a/contrib/sb-bsd-sockets/name-service.lisp +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -24,7 +24,7 @@ ;(define-condition try-again-error (socket-error)) ; temporary (defun make-host-ent (h) - (if (sb-grovel::foreign-nullp h) (name-service-error "gethostbyname")) + (if (sb-alien:null-alien h) (name-service-error "gethostbyname")) (let* ((length (sockint::hostent-length h)) (aliases (loop for i = 0 then (1+ i) for al = (sb-alien:deref (sockint::hostent-aliases h) i) @@ -41,7 +41,8 @@ (loop for i from 0 below length do (setf (elt addr i) (sb-alien:deref ad i))) addr)) - (#.sockint::af-local + #-win32 + (#.sockint::af-local (sb-alien:cast ad sb-alien:c-string)))))) (make-instance 'host-ent :name (sockint::hostent-name h) @@ -81,6 +82,7 @@ GET-NAME-SERVICE-ERRNO") (get-name-service-errno) ;; Comment next to NETDB_INTERNAL in netdb.h says "See errno.". ;; This special case treatment hasn't actually been tested yet. + #-win32 (if (= *name-service-errno* sockint::NETDB-INTERNAL) (socket-error where) (let ((condition @@ -109,7 +111,9 @@ GET-NAME-SERVICE-ERRNO") (defparameter *conditions-for-name-service-errno* nil) +#-win32 (define-name-service-condition sockint::NETDB-INTERNAL netdb-internal-error) +#-win32 (define-name-service-condition sockint::NETDB-SUCCESS netdb-success-error) (define-name-service-condition sockint::HOST-NOT-FOUND host-not-found-error) (define-name-service-condition sockint::TRY-AGAIN try-again-error) @@ -122,16 +126,17 @@ GET-NAME-SERVICE-ERRNO") (or (cdr (assoc err *conditions-for-name-service-errno* :test #'eql)) 'name-service)) - - (defun get-name-service-errno () (setf *name-service-errno* (sb-alien:alien-funcall - (sb-alien:extern-alien "get_h_errno" (function integer))))) + #-win32 + (sb-alien:extern-alien "get_h_errno" (function integer)) + #+win32 + (sb-alien:extern-alien "WSAGetLastError" (function integer))))) #-(and cmu solaris) (progn - #+sbcl + #+(and sbcl (not win32)) (sb-alien:define-alien-routine "hstrerror" sb-c-call:c-string (errno integer)) @@ -142,3 +147,7 @@ GET-NAME-SERVICE-ERRNO") (defun get-name-service-error-message (num) (hstrerror num)) ) + +;;; placeholder for hstrerror on windows +#+(and sbcl win32) +(defun hstrerror () 0) diff --git a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd index 7da9c86..b818457 100644 --- a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd +++ b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd @@ -1,29 +1,31 @@ ;;; -*- Lisp -*- -(eval-when (:compile-toplevel :load-toplevel :execute) - (require :sb-grovel)) -(defpackage #:sb-bsd-sockets-system (:use #:asdf #:sb-grovel #:cl)) +#-win32 (eval-when (:compile-toplevel :load-toplevel :execute) + (require :sb-grovel)) +(defpackage #:sb-bsd-sockets-system (:use #:asdf #-win32 #:sb-grovel #:cl)) (in-package #:sb-bsd-sockets-system) (defsystem sb-bsd-sockets :version "0.58" - :depends-on (sb-grovel) + :depends-on #-win32 (sb-grovel) #+win32 () #+sb-building-contrib :pathname #+sb-building-contrib "SYS:CONTRIB;SB-BSD-SOCKETS;" :components ((:file "defpackage") + #+win32 (:file "win32-constants" :depends-on ("defpackage")) + #+win32 (:file "win32-sockets" :depends-on ("win32-constants")) (:file "split" :depends-on ("defpackage")) (:file "malloc" :depends-on ("defpackage")) - (sb-grovel:grovel-constants-file + #-win32 (sb-grovel:grovel-constants-file "constants" :package :sockint :depends-on ("defpackage")) (:file "sockets" - :depends-on ("constants")) - + :depends-on #-win32 ("constants") + #+win32 ("win32-sockets")) (:file "sockopt" :depends-on ("sockets")) - (:file "inet" :depends-on ("sockets" "split" "constants" )) - (:file "local" :depends-on ("sockets" "split" "constants" )) - (:file "name-service" :depends-on ("sockets" "constants")) - (:file "misc" :depends-on ("sockets" "constants")) + (:file "inet" :depends-on ("sockets" "split")) + (:file "local" :depends-on ("sockets" "split")) + (:file "name-service" :depends-on ("sockets" #-win32 "constants")) + (:file "misc" :depends-on ("sockets")) (:static-file "NEWS") ;; (:static-file "INSTALL") @@ -35,14 +37,17 @@ (defmethod perform :after ((o load-op) (c (eql (find-system :sb-bsd-sockets)))) (provide 'sb-bsd-sockets)) +#-win32 (defmethod perform ((o test-op) (c (eql (find-system :sb-bsd-sockets)))) (operate 'load-op 'sb-bsd-sockets-tests) (operate 'test-op 'sb-bsd-sockets-tests)) +#-win32 (defsystem sb-bsd-sockets-tests - :depends-on (sb-rt sb-bsd-sockets sb-posix) + :depends-on (sb-rt sb-bsd-sockets #-win32 sb-posix) :components ((:file "tests"))) +#-win32 (defmethod perform ((o test-op) (c (eql (find-system :sb-bsd-sockets-tests)))) (or (funcall (intern "DO-TESTS" (find-package "SB-RT"))) (error "test-op failed"))) diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index c010811..6cff161 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -4,6 +4,11 @@ ;;;; is deferred to inet.lisp, unix.lisp, etc (eval-when (:load-toplevel :compile-toplevel :execute) + +#+win32 +(defvar *wsa-startup-call* + (sockint::wsa-startup (sockint::make-wsa-version 2 2))) + (defclass socket () ((file-descriptor :initarg :descriptor :reader socket-file-descriptor) diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp index e689a48..22a1816 100644 --- a/contrib/sb-bsd-sockets/sockopt.lisp +++ b/contrib/sb-bsd-sockets/sockopt.lisp @@ -43,7 +43,7 @@ Code for options that not every system has should be conditionalised: (if (numberp (eval level)) level `(get-protocol-by-name ,(string-downcase (symbol-name level))))) - (supportedp (or (null features) (featurep features)))) + (supportedp (or (null features) (sb-int:featurep features)))) `(progn (export ',lisp-name) (defun ,lisp-name (socket) diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp index c9954b5..f0ceba2 100644 --- a/contrib/sb-bsd-sockets/tests.lisp +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -155,6 +155,7 @@ ;;; the message ended up (deftest simple-local-client + #-win32 (progn ;; SunOS (Solaris) and Darwin systems don't have a socket at ;; /dev/log. We might also be building in a chroot or diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 1161929..05f29b1 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -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 diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 5088023..9425173 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -45,11 +45,13 @@ ;;;; 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 () +#-win32 (define-alien-routine wrapped-environ (* c-string)) +#-win32 (defun posix-environ () "Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs." (c-strings->string-list (wrapped-environ))) +;#+win32 (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 +94,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,28 +139,31 @@ (not (zerop (ldb (byte 1 7) status))))))))) ;;;; process control stuff - +#-win32 (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.")) ;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a ;;; mutex is needed. More importantly the sigchld signal handler also ;;; accesses it, that's why we need without-interrupts. +#-win32 (defmacro with-active-processes-lock (() &body body) `(without-interrupts (sb-thread:with-mutex (*active-processes-lock*) ,@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 @@ -166,7 +173,7 @@ -(defmethod print-object ((process process) stream) +#-win32 (defmethod print-object ((process process) stream) (print-unreadable-object (process stream :type t) (format stream "~W ~S" @@ -181,6 +188,7 @@ #+sb-doc (setf (documentation 'process-pid 'function) "The pid of the child process.") +#-win32 (defun process-status (process) #+sb-doc "Return the current status of PROCESS. The result is one of :RUNNING, @@ -221,6 +229,7 @@ The function is called with PROCESS as its only argument.") (setf (documentation 'process-plist 'function) "A place for clients to stash things.") +#-win32 (defun process-wait (process &optional check-for-stopped) #+sb-doc "Wait for PROCESS to quit running for some reason. @@ -238,7 +247,7 @@ The function is called with PROCESS as its only argument.") (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 +261,7 @@ The function is called with PROCESS as its only argument.") 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 @@ -289,6 +299,7 @@ The function is called with PROCESS as its only argument.") (t t))))) +#-win32 (defun process-alive-p (process) #+sb-doc "Return T if PROCESS is still alive, NIL otherwise." @@ -298,6 +309,7 @@ The function is called with PROCESS as its only argument.") t nil))) +#-win32 (defun process-close (process) #+sb-doc "Close all streams connected to PROCESS and stop maintaining the status slot." @@ -312,11 +324,11 @@ The function is called with PROCESS as its only argument.") process) ;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes -(defun sigchld-handler (ignore1 ignore2 ignore3) +#-win32 (defun sigchld-handler (ignore1 ignore2 ignore3) (declare (ignore ignore1 ignore2 ignore3)) (get-processes-status-changes)) -(defun get-processes-status-changes () +#-win32 (defun get-processes-status-changes () (loop (multiple-value-bind (pid what code core) (wait3 t t) @@ -344,12 +356,12 @@ The function is called with PROCESS as its only argument.") (defvar *close-in-parent* nil) ;;; list of handlers installed by RUN-PROGRAM -(defvar *handlers-installed* nil) +#-win32 (defvar *handlers-installed* nil) ;;; Find an unused pty. Return three values: the file descriptor for ;;; the master side of the pty, the file descriptor for the slave side ;;; of the pty, and the name of the tty device for the slave side. -(defun find-a-pty () +#-win32 (defun find-a-pty () (dolist (char '(#\p #\q)) (dotimes (digit 16) (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit) 'base-string)) @@ -369,7 +381,7 @@ The function is called with PROCESS as its only argument.") (sb-unix:unix-close master-fd)))))) (error "could not find a pty")) -(defun open-pty (pty cookie) +#-win32 (defun open-pty (pty cookie) (when pty (multiple-value-bind (master slave name) @@ -439,7 +451,7 @@ The function is called with PROCESS as its only argument.") ,@body) (sb-sys:deallocate-system-memory ,sap ,size))))) -(sb-alien:define-alien-routine spawn sb-alien:int +#-win32 (sb-alien:define-alien-routine spawn sb-alien:int (program sb-alien:c-string) (argv (* sb-alien:c-string)) (envp (* sb-alien:c-string)) @@ -448,8 +460,16 @@ The function is called with PROCESS as its only argument.") (stdout sb-alien:int) (stderr sb-alien:int)) +#+win32 (sb-alien:define-alien-routine spawn sb-win32::handle + (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) +#-win32 (defun unix-filename-is-executable-p (unix-filename) (declare (type simple-string unix-filename)) (setf unix-filename (coerce unix-filename 'base-string)) (values (and (eq (sb-unix:unix-file-kind unix-filename) :file) @@ -461,7 +481,7 @@ The function is called with PROCESS as its only argument.") #+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)) + (loop for end = (position #-win32 #\: #+win32 #\; search-path :start (if end (1+ end) 0)) and start = 0 then (and end (1+ end)) while start ;; the truename of a file naming a directory is the @@ -469,8 +489,9 @@ colon-separated list of pathnames SEARCH-PATH" ;; 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 + when #-win32 (and fullpath (unix-filename-is-executable-p (namestring fullpath))) + #+win32 t return fullpath)) ;;; FIXME: There shouldn't be two semiredundant versions of the @@ -516,7 +537,8 @@ colon-separated list of pathnames SEARCH-PATH" ;;; ;;; RUN-PROGRAM returns a PROCESS structure for the process if ;;; the fork worked, and NIL if it did not. -(defun run-program (program args + +#-win32 (defun run-program (program args &key (env nil env-p) (environment (if env-p @@ -686,6 +708,122 @@ colon-separated list of pathnames SEARCH-PATH" (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 NIL or 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 + (namestring (find-executable-in-search-path program)) + (namestring program))) + (cookie (list 0))) + (unless pfile + (error "no such program: ~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 ((iwait (if wait 1 0))) + (declare (type fixnum iwait)) + (let ((child-pid + (without-gcing + (spawn pfile args-vec + stdin stdout stderr + iwait)))) + (when (< child-pid 0) + (error "couldn't spawn program: ~A" + (strerror))) + (setf proc + (if wait + nil + (make-process :pid child-pid + :%status :running + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie))))))))))) + 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 +858,10 @@ colon-separated list of pathnames SEARCH-PATH" (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 +898,8 @@ colon-separated list of pathnames SEARCH-PATH" ;; 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) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index f2147a6..db36cfb 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -489,10 +489,20 @@ steppers to maintain contextual information.") #!-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 diff --git a/src/code/unix.lisp b/src/code/unix.lisp index d4666d7..8312381 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -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 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;;; 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 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; 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 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; 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 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; 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 diff --git a/src/code/win32.lisp b/src/code/win32.lisp index 4176938..8b055ea 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -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. @@ -348,3 +352,125 @@ (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))))) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index f4687da..3aff541 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -168,7 +168,7 @@ "SRC;CODE;PROFILE" "SRC;CODE;NTRACE" "SRC;CODE;STEP" - #-win32 "SRC;CODE;RUN-PROGRAM" + "SRC;CODE;RUN-PROGRAM" ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT ;; facility is still used in our ANSI DESCRIBE diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 171431d..e9ae52c 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -154,8 +154,8 @@ #!+win32 (progn - (def!constant read-only-space-start #x01000000) - (def!constant read-only-space-end #x037ff000) + (def!constant read-only-space-start #x02000000) + (def!constant read-only-space-end #x047ff000) (def!constant static-space-start #x05000000) (def!constant static-space-end #x07fff000) diff --git a/src/runtime/run-program.c b/src/runtime/run-program.c index 110d2b4..feb8d8d 100644 --- a/src/runtime/run-program.c +++ b/src/runtime/run-program.c @@ -121,4 +121,83 @@ int spawn(char *program, char *argv[], char *envp[], char *pty_name, /* The exec didn't work, flame out. */ exit(1); } +#else /* !LISP_FEATURE_WIN32 */ + +# include +# include +# include +# include +# include +# include + +#define READ_HANDLE 0 +#define WRITE_HANDLE 1 + +/* These functions do not attempt to deal with wchar_t variations. */ + +/* Get the value of _environ maintained by MSVCRT */ +char **msvcrt_environ ( void ) { + return ( _environ ); +} + +/* Set up in, out, err pipes and spawn a program, waiting or otherwise. */ +HANDLE spawn ( + const char *program, + const char *const *argv, + int in, + int out, + int err, + int wait + ) +{ + int fdOut, fdIn, fdErr, fdInPipe[2], fdOutPipe[2], fdErrPipe[2], wait_mode; + HANDLE hProcess; + + /* Make pipes to be passed to the spawned process as in/out/err */ + if ( _pipe ( fdOutPipe, 512, O_TEXT | O_NOINHERIT ) == -1 ) return (HANDLE)-1; + if ( _pipe ( fdInPipe, 512, O_TEXT | O_NOINHERIT ) == -1 ) return (HANDLE)-1; + if ( _pipe ( fdErrPipe, 512, O_TEXT | O_NOINHERIT ) == -1 ) return (HANDLE)-1; + + /* Duplicate and save original in/out/err handles */ + fdOut = _dup ( out ); + fdIn = _dup ( in ); + fdErr = _dup ( err ); + + /* Duplicate write end of new pipes to current out/err handles, + * read to in */ + if ( _dup2 ( fdOutPipe[WRITE_HANDLE], out ) != 0 ) return (HANDLE)-1; + if ( _dup2 ( fdInPipe[READ_HANDLE], in ) != 0 ) return (HANDLE)-1; + if ( _dup2 ( fdErrPipe[WRITE_HANDLE], err ) != 0 ) return (HANDLE)-1; + + + /* Close the duplicated handles to the new pipes */ + close ( fdOutPipe[WRITE_HANDLE] ); + close ( fdInPipe[READ_HANDLE] ); + close ( fdErrPipe[WRITE_HANDLE] ); + + /* Set the wait mode. */ + if ( 0 == wait ) { + wait_mode = P_NOWAIT; + } else { + wait_mode = P_WAIT; + } + + /* Spawn process given on the command line*/ + hProcess = (HANDLE) spawnvp ( wait_mode, program, argv ); + + /* Now that the process is launched, replace the original + * in/out/err handles */ + if ( _dup2 ( fdOut, out ) != 0 ) return (HANDLE)-1; + if ( _dup2 ( fdIn, in ) != 0 ) return (HANDLE)-1; + if ( _dup2 ( fdErr, err ) != 0 ) return (HANDLE)-1; + + /* Close duplicates */ + close(fdOut); + close(fdIn); + close(fdErr); + + return ( hProcess ); +} + + #endif /* !LISP_FEATURE_WIN32 */ diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c index 0073c60..10c51d7 100644 --- a/src/runtime/win32-os.c +++ b/src/runtime/win32-os.c @@ -29,6 +29,7 @@ #include #include #include +#include #include "sbcl.h" #include "./signal.h" #include "os.h" @@ -48,6 +49,7 @@ #include #include #include +#include #include @@ -621,17 +623,33 @@ void scratch(void) hypot(0, 0); write(0, 0, 0); close(0); - rename(0,0); - getcwd(0,0); + #ifndef LISP_FEATURE_SB_UNICODE + MoveFileA(0,0); + #else + MoveFileW(0,0); + #endif + #ifndef LISP_FEATURE_SB_UNICODE + GetCurrentDirectoryA(0,0); + #else + GetCurrentDirectoryW(0,0); + #endif dup(0); LoadLibrary(0); GetProcAddress(0, 0); FreeLibrary(0); - mkdir(0); + #ifndef LISP_FEATURE_SB_UNICODE + CreateDirectoryA(0,0); + #else + CreateDirectoryW(0,0); + #endif + _pipe(0,0,0); isatty(0); access(0,0); GetLastError(); FormatMessageA(0, 0, 0, 0, 0, 0, 0); + #ifdef LISP_FEATURE_SB_UNICODE + FormatMessageW(0, 0, 0, 0, 0, 0, 0); + #endif _get_osfhandle(0); ReadFile(0, 0, 0, 0, 0); WriteFile(0, 0, 0, 0, 0); @@ -639,8 +657,19 @@ void scratch(void) FlushConsoleInputBuffer(0); PeekConsoleInput(0, 0, 0, 0); Sleep(0); + #ifndef LISP_FEATURE_SB_UNICODE + SHGetFolderPathA(0, 0, 0, 0, 0); + #else + SHGetFolderPathW(0, 0, 0, 0, 0); + #endif GetACP(); GetOEMCP(); + LocalFree(0); + #ifndef LISP_FEATURE_SB_UNICODE + GetEnvironmentVariableA(0,0,0); + #else + GetEnvironmentVariableW(0,0,0); + #endif GetConsoleCP(); GetConsoleOutputCP(); } diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index a7600d9..9b533d4 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -24,6 +24,7 @@ #define WIN32_LEAN_AND_MEAN #include #include + #include #else #include #include @@ -85,6 +86,78 @@ main(int argc, char *argv[]) printf("(in-package \"SB!WIN32\")\n\n"); defconstant ("input-record-size", sizeof (INPUT_RECORD)); + + defconstant ("MAX_PATH", MAX_PATH); + + printf(";;; CSIDL\n"); + + defconstant ("CSIDL_DESKTOP", CSIDL_DESKTOP); + defconstant ("CSIDL_INTERNET", CSIDL_INTERNET); + defconstant ("CSIDL_PROGRAMS", CSIDL_PROGRAMS); + defconstant ("CSIDL_CONTROLS", CSIDL_CONTROLS); + defconstant ("CSIDL_PRINTERS", CSIDL_PRINTERS); + defconstant ("CSIDL_PERSONAL", CSIDL_PERSONAL); + defconstant ("CSIDL_FAVORITES", CSIDL_FAVORITES); + defconstant ("CSIDL_STARTUP", CSIDL_STARTUP); + defconstant ("CSIDL_RECENT", CSIDL_RECENT); + defconstant ("CSIDL_SENDTO", CSIDL_SENDTO); + defconstant ("CSIDL_BITBUCKET", CSIDL_BITBUCKET); + defconstant ("CSIDL_STARTMENU", CSIDL_STARTMENU); + defconstant ("CSIDL_DESKTOPDIRECTORY", CSIDL_DESKTOPDIRECTORY); + defconstant ("CSIDL_DRIVES", CSIDL_DRIVES); + defconstant ("CSIDL_NETWORK", CSIDL_NETWORK); + defconstant ("CSIDL_NETHOOD", CSIDL_NETHOOD); + defconstant ("CSIDL_FONTS", CSIDL_FONTS); + defconstant ("CSIDL_TEMPLATES", CSIDL_TEMPLATES); + defconstant ("CSIDL_COMMON_STARTMENU", CSIDL_COMMON_STARTMENU); + defconstant ("CSIDL_COMMON_PROGRAMS", CSIDL_COMMON_PROGRAMS); + defconstant ("CSIDL_COMMON_STARTUP", CSIDL_COMMON_STARTUP); + defconstant ("CSIDL_COMMON_DESKTOPDIRECTORY", CSIDL_COMMON_DESKTOPDIRECTORY); + defconstant ("CSIDL_APPDATA", CSIDL_APPDATA); + defconstant ("CSIDL_PRINTHOOD", CSIDL_PRINTHOOD); + defconstant ("CSIDL_LOCAL_APPDATA", CSIDL_LOCAL_APPDATA); + defconstant ("CSIDL_ALTSTARTUP", CSIDL_ALTSTARTUP); + defconstant ("CSIDL_COMMON_ALTSTARTUP", CSIDL_COMMON_ALTSTARTUP); + defconstant ("CSIDL_COMMON_FAVORITES", CSIDL_COMMON_FAVORITES); + defconstant ("CSIDL_INTERNET_CACHE", CSIDL_INTERNET_CACHE); + defconstant ("CSIDL_COOKIES", CSIDL_COOKIES); + defconstant ("CSIDL_HISTORY", CSIDL_HISTORY); + defconstant ("CSIDL_COMMON_APPDATA", CSIDL_COMMON_APPDATA); + defconstant ("CSIDL_WINDOWS", CSIDL_WINDOWS); + defconstant ("CSIDL_SYSTEM", CSIDL_SYSTEM); + defconstant ("CSIDL_PROGRAM_FILES", CSIDL_PROGRAM_FILES); + defconstant ("CSIDL_MYPICTURES", CSIDL_MYPICTURES); + defconstant ("CSIDL_PROFILE", CSIDL_PROFILE); + defconstant ("CSIDL_SYSTEMX86", CSIDL_SYSTEMX86); + defconstant ("CSIDL_PROGRAM_FILESX86", CSIDL_PROGRAM_FILESX86); + defconstant ("CSIDL_PROGRAM_FILES_COMMON", CSIDL_PROGRAM_FILES_COMMON); + defconstant ("CSIDL_PROGRAM_FILES_COMMONX86", CSIDL_PROGRAM_FILES_COMMONX86); + defconstant ("CSIDL_COMMON_TEMPLATES", CSIDL_COMMON_TEMPLATES); + defconstant ("CSIDL_COMMON_DOCUMENTS", CSIDL_COMMON_DOCUMENTS); + defconstant ("CSIDL_COMMON_ADMINTOOLS", CSIDL_COMMON_ADMINTOOLS); + defconstant ("CSIDL_ADMINTOOLS", CSIDL_ADMINTOOLS); + defconstant ("CSIDL_CONNECTIONS", CSIDL_CONNECTIONS); + defconstant ("CSIDL_COMMON_MUSIC", CSIDL_COMMON_MUSIC); + defconstant ("CSIDL_COMMON_PICTURES", CSIDL_COMMON_PICTURES); + defconstant ("CSIDL_COMMON_VIDEO", CSIDL_COMMON_VIDEO); + defconstant ("CSIDL_RESOURCES", CSIDL_RESOURCES); + defconstant ("CSIDL_RESOURCES_LOCALIZED", CSIDL_RESOURCES_LOCALIZED); + defconstant ("CSIDL_COMMON_OEM_LINKS", CSIDL_COMMON_OEM_LINKS); + defconstant ("CSIDL_CDBURN_AREA", CSIDL_CDBURN_AREA); + defconstant ("CSIDL_COMPUTERSNEARME", CSIDL_COMPUTERSNEARME); + defconstant ("CSIDL_FLAG_DONT_VERIFY", CSIDL_FLAG_DONT_VERIFY); + defconstant ("CSIDL_FLAG_CREATE", CSIDL_FLAG_CREATE); + defconstant ("CSIDL_FLAG_MASK", CSIDL_FLAG_MASK); + + printf(";;; FormatMessage\n"); + + defconstant ("FORMAT_MESSAGE_ALLOCATE_BUFFER", FORMAT_MESSAGE_ALLOCATE_BUFFER); + defconstant ("FORMAT_MESSAGE_FROM_SYSTEM", FORMAT_MESSAGE_FROM_SYSTEM); + + printf(";;; Errors\n"); + + defconstant ("ERROR_ENVVAR_NOT_FOUND", ERROR_ENVVAR_NOT_FOUND); + #else printf("(in-package \"SB!ALIEN\")\n\n"); diff --git a/version.lisp-expr b/version.lisp-expr index 6390dc1..bba5a72 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.11.12" +"0.9.11.13" -- 1.7.10.4