;;;; -*- 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
+#+(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)
;; 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)))
(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))
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))
(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)))
;(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)
(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)
(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
(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)
(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))
(defun get-name-service-error-message (num)
(hstrerror num))
)
+
+;;; placeholder for hstrerror on windows
+#+(and sbcl win32)
+(defun hstrerror () 0)
;;; -*- 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")
(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")))
;;;; 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)
(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)
;;; 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
(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
;;;; 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.
;;;
\f
;;;; 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. "
(not (zerop (ldb (byte 1 7) status)))))))))
\f
;;;; 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
-(defmethod print-object ((process process) stream)
+#-win32 (defmethod print-object ((process process) stream)
(print-unreadable-object (process stream :type t)
(format stream
"~W ~S"
#+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,
(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.
(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))
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
(t
t)))))
+#-win32
(defun process-alive-p (process)
#+sb-doc
"Return T if PROCESS is still alive, NIL otherwise."
t
nil)))
+#-win32
(defun process-close (process)
#+sb-doc
"Close all streams connected to PROCESS and stop maintaining the status slot."
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)
(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))
(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)
,@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))
(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)
#+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
;; <Krystof> the truename of a file naming a directory is the
;; 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
;;;
;;; 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
(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.
(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))
;; 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)
#!-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
\f
;;;; 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))
\f
;;;; 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."
;;; 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))
;;; 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)
;;; 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
(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.
(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)))))
"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
#!+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)
/* The exec didn't work, flame out. */
exit(1);
}
+#else /* !LISP_FEATURE_WIN32 */
+
+# include <windows.h>
+# include <process.h>
+# include <stdio.h>
+# include <stdlib.h>
+# include <fcntl.h>
+# include <io.h>
+
+#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 */
#include <stdio.h>
#include <sys/param.h>
#include <sys/file.h>
+#include <io.h>
#include "sbcl.h"
#include "./signal.h"
#include "os.h"
#include <sys/time.h>
#include <sys/stat.h>
#include <unistd.h>
+#include <shlobj.h>
#include <excpt.h>
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);
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();
}
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#include <stdlib.h>
+ #include <shlobj.h>
#else
#include <sys/times.h>
#include <sys/wait.h>
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");
;;; 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"
projects / sbcl.git / commitdiff