;;;; functions, converting between HANDLES and fds
(defconstant WSA_FLAG_OVERLAPPED 1)
+(declaim (inline handle->fd fd->handle))
-(defun socket (af type proto)
- (let* ((handle (wsa-socket af type proto nil 0 WSA_FLAG_OVERLAPPED))
- (fd (handle->fd handle 0)))
- fd))
-
-(defun bind (fd &rest options)
- (let ((handle (fd->handle fd)))
- (apply #'win32-bind handle options)))
-
-(defun getsockname (fd &rest options)
- (apply #'win32-getsockname (fd->handle fd) options))
-
-(defun listen (fd &rest options)
- (apply #'win32-listen (fd->handle fd) options))
-
-(defun accept (fd &rest options)
- (handle->fd
- (apply #'win32-accept (fd->handle fd) options)
- 0))
-
-(defun recv (fd &rest options)
- (apply #'win32-recv (fd->handle fd) options))
-
-(defun recvfrom (fd &rest options)
- (apply #'win32-recvfrom (fd->handle fd) options))
-
-(defun send (fd &rest options)
- (apply #'win32-send (fd->handle fd) options))
+;;; For a few more releases, let's preserve old functions (now
+;;; implemented as identity) for user code which might have had to peek
+;;; into our internals in past versions when we hadn't been using
+;;; handles yet. -- DFL, 2012
+(defun handle->fd (handle flags) (declare (ignore flags)) handle)
+(defun fd->handle (fd) fd)
-(defun sendto (fd &rest options)
- (apply #'win32-sendto (fd->handle fd) options))
-
-(defun close (fd &rest options)
- (apply #'win32-close (fd->handle fd) options))
-
-(defun connect (fd &rest options)
- (apply #'win32-connect (fd->handle fd) options))
-
-(defun getpeername (fd &rest options)
- (apply #'win32-getpeername (fd->handle fd) options))
-
-(defun ioctl (fd &rest options)
- (apply #'win32-ioctl (fd->handle fd) options))
-
-(defun setsockopt (fd &rest options)
- (apply #'win32-setsockopt (fd->handle fd) options))
-
-(defun getsockopt (fd &rest options)
- (apply #'win32-getsockopt (fd->handle fd) options))
+(defun socket (af type proto)
+ (wsa-socket af type proto nil 0 WSA_FLAG_OVERLAPPED))
+
+;;; For historical reasons, the FFI functions declared in win32-constants
+;;; prepend "win32-" to the symbol names. Rather than break compatibility
+;;; for users depending on those names, wrap the misnamed functions in
+;;; correctly named ones...
+(macrolet ((define-socket-fd-arg-routines (&rest names)
+ `(progn
+ (declaim (inline ,@names))
+ ,@(loop for routine in names collect
+ `(defun ,routine (handle &rest options)
+ (apply #',(sb-int:symbolicate "WIN32-" routine)
+ handle options))))))
+ (define-socket-fd-arg-routines
+ bind getsockname listen recv recvfrom send sendto close connect
+ getpeername ioctl setsockopt getsockopt))
+
+(defun accept (handle &rest options)
+ (let ((handle (apply #'win32-accept handle options)))
+ (if (= handle -1)
+ -1
+ handle)))
(defun make-wsa-version (major minor)
(dpb minor (byte 8 8) major))
(with-stream-class (file-simple-stream stream)
(let ((fd (or (sm input-handle stream) (sm output-handle stream)))
(closed nil))
- (when (sb-int:fixnump fd)
+ (when (integerp fd)
(cond (abort
(when (any-stream-instance-flags stream :output)
#+win32 (progn (sb-unix:unix-close fd) (setf closed t))
(defmethod device-file-position ((stream file-simple-stream))
(with-stream-class (file-simple-stream stream)
(let ((fd (or (sm input-handle stream) (sm output-handle stream))))
- (if (sb-int:fixnump fd)
+ (if (integerp fd)
(values (sb-unix:unix-lseek fd 0 sb-unix:l_incr))
(file-position fd)))))
(declare (type fixnum value))
(with-stream-class (file-simple-stream stream)
(let ((fd (or (sm input-handle stream) (sm output-handle stream))))
- (if (sb-int:fixnump fd)
+ (if (integerp fd)
(values (sb-unix:unix-lseek fd
(if (minusp value) (1+ value) value)
(if (minusp value) sb-unix:l_xtnd sb-unix:l_set)))
(defmethod device-file-length ((stream file-simple-stream))
(with-stream-class (file-simple-stream stream)
(let ((fd (or (sm input-handle stream) (sm output-handle stream))))
- (if (sb-int:fixnump fd)
+ (if (integerp fd)
(multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
(sb-unix:unix-fstat (sm input-handle stream))
(declare (ignore dev ino mode nlink uid gid rdev))
(prot (logior (if input sb-posix::PROT-READ 0)
(if output sb-posix::PROT-WRITE 0)))
(fd (or (sm input-handle stream) (sm output-handle stream))))
- (unless (sb-int:fixnump fd)
+ (unless (integerp fd)
(error "Can't memory-map an encapsulated stream."))
(multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
(sb-unix:unix-fstat fd)
;; eagain into
;; sb-unix
11)
- (= errno sb-unix:ewouldblock)))
+ (= errno
+ #-win32
+ sb-unix:ewouldblock
+ #+win32
+ sb-unix:eintr)))
(sb-sys:wait-until-fd-usable fd :input nil)
(go again))
(t (return (- -10 errno)))))
(loop
(multiple-value-bind (fd errno)
(if name
+ #+win32
+ (sb-win32:unixlike-open name mask mode)
+ #-win32
(sb-unix:unix-open name mask mode)
(values nil sb-unix:enoent))
- (cond ((sb-int:fixnump fd)
+ (cond ((integerp fd)
(when (eql if-exists :append)
(sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
(return (values fd name original delete-original)))
"USER-HOMEDIR"
"WITH-RESTARTED-SYSCALL"
"SB-MKSTEMP"
+ "UNIX-OFFSET"
"FD-TYPE"
;; stuff with a one-to-one mapping to Unix constructs
"UNIXLIKE-CLOSE"
"UNIXLIKE-OPEN"
"UNMAP-VIEW-OF-FILE"
+ "WAIT-OBJECT-OR-SIGNAL"
"WRITE-FILE"
"WITH-PROCESS-TIMES")))
;; the type of element being transfered
(element-type 'base-char)
;; the Unix file descriptor
- (fd -1 :type fixnum)
+ (fd -1 :type #!-win32 fixnum #!+win32 sb!vm:signed-word)
;; What do we know about the FD?
(fd-type :unknown :type keyword)
;; controls when the output buffer is flushed
(declare (fd-stream stream))
(without-interrupts
(let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)))
- (declare (type (or (alien sb!unix:off-t) null) posn))
+ (declare (type (or (alien sb!unix:unix-offset) null) posn))
;; We used to return NIL for errno==ESPIPE, and signal an error
;; in other failure cases. However, CLHS says to return NIL if
;; the position cannot be determined -- so that's what we do.
(defun fd-stream-set-file-position (stream position-spec)
(declare (fd-stream stream))
(check-type position-spec
- (or (alien sb!unix:off-t) (member nil :start :end))
+ (or (alien sb!unix:unix-offset) (member nil :start :end))
"valid file position designator")
(tagbody
:again
(t
(values (* position-spec (fd-stream-element-size stream))
sb!unix:l_set)))
- (declare (type (alien sb!unix:off-t) offset))
+ (declare (type (alien sb!unix:unix-offset) offset))
(let ((posn (sb!unix:unix-lseek (fd-stream-fd stream)
offset origin)))
;; CLHS says to return true if the file-position was set
;; FIXME: We are still liable to signal an error if flushing
;; output fails.
(return-from fd-stream-set-file-position
- (typep posn '(alien sb!unix:off-t))))))))
+ (typep posn '(alien sb!unix:unix-offset))))))))
\f
;;;; creation routines (MAKE-FD-STREAM and OPEN)
(defun stdstream-external-format (fd outputp)
#!-win32 (declare (ignore fd outputp))
- (let* ((keyword #!+win32 (let ((handle (sb!win32:get-osfhandle fd)))
- (if (and (/= handle -1)
- (logbitp 0 handle)
- (logbitp 1 handle))
- :ucs-2
- (if outputp
- (sb!win32::console-output-codepage)
- (sb!win32::console-input-codepage))))
+ (let* ((keyword #!+win32 (if (and (/= fd -1)
+ (logbitp 0 fd)
+ (logbitp 1 fd))
+ :ucs-2
+ (if outputp
+ (sb!win32::console-output-codepage)
+ (sb!win32::console-input-codepage)))
#!-win32 (default-external-format))
(ef (get-external-format keyword))
(replacement (ef-default-replacement-character ef)))
(aver (not (boundp '*available-buffers*)))
(setf *available-buffers* nil)))
(with-output-to-string (*error-output*)
- (setf *stdin*
- (make-fd-stream 0 :name "standard input" :input t :buffering :line
- :element-type :default
- :serve-events t
- :external-format (stdstream-external-format 0 nil)))
- (setf *stdout*
- (make-fd-stream 1 :name "standard output" :output t :buffering :line
- :element-type :default
- :external-format (stdstream-external-format 1 t)))
- (setf *stderr*
- (make-fd-stream 2 :name "standard error" :output t :buffering :line
- :element-type :default
- :external-format (stdstream-external-format 2 t)))
+ (multiple-value-bind (in out err)
+ #!-win32 (values 0 1 2)
+ #!+win32 (sb!win32::get-std-handles)
+ (flet ((stdio-stream (handle name inputp outputp)
+ (make-fd-stream
+ handle
+ :name name
+ :input inputp
+ :output outputp
+ :buffering :line
+ :element-type :default
+ :serve-events inputp
+ :external-format (stdstream-external-format handle outputp))))
+ (setf *stdin* (stdio-stream in "standard input" t nil))
+ (setf *stdout* (stdio-stream out "standard output" nil t))
+ (setf *stderr* (stdio-stream err "standard error" nil t))))
+ #!+win32
+ (setf *tty* (make-two-way-stream *stdin* *stdout*))
+ #!-win32
(let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
(tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
(if tty
(defstruct (process (:copier nil))
pid ; PID of child process
%status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
- exit-code ; either exit code or signal
+ %exit-code ; either exit code or signal
core-dumped ; T if a core image was dumped
#-win32 pty ; stream to child's pty, or NIL
input ; stream to child's input, or NIL
(print-unreadable-object (process stream :type t)
(let ((status (process-status process)))
(if (eq :exited status)
- (format stream "~S ~S" status (process-exit-code process))
+ (format stream "~S ~S" status (process-%exit-code process))
(format stream "~S ~S" (process-pid process) status)))
process))
int
(handle unsigned) (exit-code unsigned :out))
+(defun process-exit-code (process)
+ #+sb-doc
+ "Return the exit code of PROCESS."
+ (or (process-%exit-code process)
+ (progn (get-processes-status-changes)
+ (process-%exit-code process))))
+
(defun process-status (process)
#+sb-doc
"Return the current status of PROCESS. The result is one of :RUNNING,
"Wait for PROCESS to quit running for some reason. When
CHECK-FOR-STOPPED is T, also returns when PROCESS is stopped. Returns
PROCESS."
+ (declare (ignorable check-for-stopped))
+ #+win32
+ (let ((pid (process-pid process)))
+ (when (and pid (plusp pid))
+ (without-interrupts
+ (do ()
+ ((= 0
+ (with-local-interrupts
+ (sb-win32:wait-object-or-signal pid))))))))
+ #-win32
(loop
(case (process-status process)
(:running)
((and (eql pid (process-pid process))
(= signal sb-unix:sigcont))
(setf (process-%status process) :running)
- (setf (process-exit-code process) nil)
+ (setf (process-%exit-code process) nil)
(when (process-status-hook process)
(funcall (process-status-hook process) process))
t)
;; maybe it should be set to :CLOSED, or similar?
(with-active-processes-lock ()
(setf *active-processes* (delete process *active-processes*)))
+ #+win32
+ (let ((handle (shiftf (process-pid process) nil)))
+ (when (and handle (plusp handle))
+ (or (sb-win32:close-handle handle)
+ (sb-win32::win32-error 'process-close))))
process)
(defun get-processes-status-changes ()
(waitpid (process-pid proc) t t)
(when pid
(setf (process-%status proc) what)
- (setf (process-exit-code proc) code)
+ (setf (process-%exit-code proc) code)
(setf (process-core-dumped proc) core)
(when (process-status-hook proc)
(push proc exited))
t)))
#+win32
(lambda (proc)
- (multiple-value-bind (ok code)
- (get-exit-code-process (process-pid proc))
- (when (and (plusp ok) (/= code 259))
- (setf (process-%status proc) :exited
- (process-exit-code proc) code)
- (when (process-status-hook proc)
- (push proc exited))
- t)))
+ (let ((pid (process-pid proc)))
+ (when pid
+ (multiple-value-bind (ok code)
+ (sb-win32::get-exit-code-process pid)
+ (when (and (plusp ok) (/= code 259))
+ (setf (process-%status proc) :exited
+ (process-%exit-code proc) code)
+ (when (process-status-hook proc)
+ (push proc exited))
+ t)))))
*active-processes*)))
;; Can't call the hooks before all the processes have been deal
;; with, as calling a hook may cause re-entry to
;; expand into UNWIND-PROTECT forms. They're just
;; syntactic sugar to make the rest of the routine slightly
;; easier to read.
- (macrolet ((with-fd-and-stream-for (((fd stream) which &rest args)
+ (macrolet ((with-no-with
+ ((&optional no)
+ (&whole form with-something parameters &body body))
+ (declare (ignore with-something parameters))
+ (typecase no
+ (keyword `(progn ,@body))
+ (null form)
+ (t `(let ,no (declare (ignorable ,@no)) ,@body))))
+ (with-fd-and-stream-for (((fd stream) which &rest args)
&body body)
`(multiple-value-bind (,fd ,stream)
,(ecase which
,@body))
(with-open-pty (((pty-name pty-stream) (pty cookie))
&body body)
- #+win32 `(declare (ignore ,pty ,cookie))
- #+win32 `(let (,pty-name ,pty-stream) ,@body)
- #-win32 `(multiple-value-bind (,pty-name ,pty-stream)
- (open-pty ,pty ,cookie :external-format external-format)
- ,@body))
+ `(multiple-value-bind (,pty-name ,pty-stream)
+ (open-pty ,pty ,cookie :external-format external-format)
+ ,@body))
(with-args-vec ((vec args) &body body)
`(with-c-strvec (,vec ,args)
,@body))
:direction :output
:if-exists if-error-exists
:external-format external-format)
- (with-open-pty ((pty-name pty-stream) (pty cookie))
- ;; Make sure we are not notified about the child
- ;; death before we have installed the PROCESS
- ;; structure in *ACTIVE-PROCESSES*.
- (let (child)
- (with-active-processes-lock ()
- (with-args-vec (args-vec simple-args)
- (with-environment-vec (environment-vec)
- (setq child (without-gcing
- (spawn progname args-vec
- stdin stdout stderr
- (if search 1 0)
- environment-vec pty-name
- (if wait 1 0))))))
- (unless (minusp child)
- (setf proc
- (apply
- #'make-process
- :pid child
- :input input-stream
- :output output-stream
- :error error-stream
- :status-hook status-hook
- :cookie cookie
- #-win32 (list :pty pty-stream
- :%status :running)
- #+win32 (if wait
- (list :%status :exited
- :exit-code child)
- (list :%status :running))))
- (push proc *active-processes*)))
- ;; Report the error outside the lock.
- #+win32
- (when (minusp child)
- (error "Couldn't execute ~S: ~A" progname (strerror)))
- #-win32
- (case child
- (-2
- (error "Couldn't execute ~S: ~A" progname (strerror)))
- (-1
- (error "Couldn't fork child process: ~A" (strerror))))))))))
+ (with-no-with (#+win32 (pty-name pty-stream))
+ (with-open-pty ((pty-name pty-stream) (pty cookie))
+ ;; Make sure we are not notified about the child
+ ;; death before we have installed the PROCESS
+ ;; structure in *ACTIVE-PROCESSES*.
+ (let (child)
+ (with-active-processes-lock ()
+ (with-no-with (#+win32 (args-vec))
+ (with-args-vec (args-vec simple-args)
+ (with-no-with (#+win32 (environment-vec))
+ (with-environment-vec (environment-vec)
+ (setq child
+ #+win32
+ (sb-win32::mswin-spawn
+ progname
+ (with-output-to-string (argv)
+ (dolist (arg simple-args)
+ (write-string arg argv)
+ (write-char #\Space argv)))
+ stdin stdout stderr
+ search nil wait)
+ #-win32
+ (without-gcing
+ (spawn progname args-vec
+ stdin stdout stderr
+ (if search 1 0)
+ environment-vec pty-name
+ (if wait 1 0))))
+ (unless (minusp child)
+ (setf proc
+ (apply
+ #'make-process
+ :input input-stream
+ :output output-stream
+ :error error-stream
+ :status-hook status-hook
+ :cookie cookie
+ #-win32 (list :pty pty-stream
+ :%status :running
+ :pid child)
+ #+win32 (if wait
+ (list :%status :exited
+ :%exit-code child)
+ (list :%status :running
+ :pid child))))
+ (push proc *active-processes*)))))))
+ ;; Report the error outside the lock.
+ (case child
+ (-2
+ (error "Couldn't execute ~S: ~A" progname (strerror)))
+ (-1
+ (error "Couldn't fork child process: ~A" (strerror)))))))))))
(dolist (fd *close-in-parent*)
(sb-unix:unix-close fd))
(unless proc
(sb-unix:unix-close fd)
(error "failed to unlink ~A" name/errno))
fd)))
- (cond ((eq object t)
- ;; No new descriptor is needed.
- (values -1 nil))
- ((or (eq object nil)
- (and (typep object 'broadcast-stream)
- (not (broadcast-stream-streams object))))
- ;; Use /dev/null.
- (multiple-value-bind
- (fd errno)
- (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)
- (t sb-unix:o_rdwr))
- #o666)
- (unless fd
- (error #-win32 "~@<couldn't open \"/dev/null\": ~2I~_~A~:>"
- #+win32 "~@<couldn't open \"nul\" device: ~2I~_~A~:>"
- (strerror errno)))
- (push fd *close-in-parent*)
- (values fd nil)))
- ((eq object :stream)
- (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe)
- (unless read-fd
- (error "couldn't create pipe: ~A" (strerror write-fd)))
- (case direction
- (:input
- (push read-fd *close-in-parent*)
- (push write-fd *close-on-error*)
- (let ((stream (sb-sys:make-fd-stream write-fd :output t
- :element-type :default
- :external-format
- external-format)))
- (values read-fd stream)))
- (:output
- (push read-fd *close-on-error*)
- (push write-fd *close-in-parent*)
- (let ((stream (sb-sys:make-fd-stream read-fd :input t
- :element-type :default
- :external-format
- external-format)))
- (values write-fd stream)))
- (t
- (sb-unix:unix-close read-fd)
- (sb-unix:unix-close write-fd)
- (error "Direction must be either :INPUT or :OUTPUT, not ~S."
- direction)))))
- ((or (pathnamep object) (stringp object))
- ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather
- ;; than munge the &rest list for OPEN, just disable keyword
- ;; validation there.
- (with-open-stream (file (apply #'open object :allow-other-keys t
- keys))
- (when file
- (multiple-value-bind
- (fd errno)
- (sb-unix:unix-dup (sb-sys:fd-stream-fd file))
- (cond (fd
- (push fd *close-in-parent*)
- (values fd nil))
- (t
- (error "couldn't duplicate file descriptor: ~A"
- (strerror errno))))))))
+ (let ((dev-null #.(coerce #-win32 "/dev/null" #+win32 "nul" 'base-string)))
+ (cond ((eq object t)
+ ;; No new descriptor is needed.
+ (values -1 nil))
+ ((or (eq object nil)
+ (and (typep object 'broadcast-stream)
+ (not (broadcast-stream-streams object))))
+ ;; Use /dev/null.
+ (multiple-value-bind
+ (fd errno)
+ (sb-unix:unix-open dev-null
+ (case direction
+ (:input sb-unix:o_rdonly)
+ (:output sb-unix:o_wronly)
+ (t sb-unix:o_rdwr))
+ #o666)
+ (unless fd
+ (error "~@<couldn't open ~S: ~2I~_~A~:>"
+ dev-null (strerror errno)))
+ #+win32
+ (setf (sb-win32::inheritable-handle-p fd) t)
+ (push fd *close-in-parent*)
+ (values fd nil)))
+ ((eq object :stream)
+ (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe)
+ (unless read-fd
+ (error "couldn't create pipe: ~A" (strerror write-fd)))
+ #+win32
+ (setf (sb-win32::inheritable-handle-p read-fd)
+ (eq direction :input)
+ (sb-win32::inheritable-handle-p write-fd)
+ (eq direction :output))
+ (case direction
+ (:input
+ (push read-fd *close-in-parent*)
+ (push write-fd *close-on-error*)
+ (let ((stream (sb-sys:make-fd-stream write-fd :output t
+ :element-type :default
+ :external-format
+ external-format)))
+ (values read-fd stream)))
+ (:output
+ (push read-fd *close-on-error*)
+ (push write-fd *close-in-parent*)
+ (let ((stream (sb-sys:make-fd-stream read-fd :input t
+ :element-type :default
+ :external-format
+ external-format)))
+ (values write-fd stream)))
+ (t
+ (sb-unix:unix-close read-fd)
+ (sb-unix:unix-close write-fd)
+ (error "Direction must be either :INPUT or :OUTPUT, not ~S."
+ direction)))))
+ ((or (pathnamep object) (stringp object))
+ ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather
+ ;; than munge the &rest list for OPEN, just disable keyword
+ ;; validation there.
+ (with-open-stream (file (apply #'open object :allow-other-keys t
+ keys))
+ (when file
+ (multiple-value-bind
+ (fd errno)
+ (sb-unix:unix-dup (sb-sys:fd-stream-fd file))
+ (cond (fd
+ (push fd *close-in-parent*)
+ (values fd nil))
+ (t
+ (error "couldn't duplicate file descriptor: ~A"
+ (strerror errno))))))))
((streamp object)
(ecase direction
(:input
external-format)
(push read-fd *close-on-error*)
(push write-fd *close-in-parent*)
- (return (values write-fd nil)))))))
- (t
- (error "invalid option to RUN-PROGRAM: ~S" object)))))
+ (return (values write-fd nil)))))
+ (t
+ (error "invalid option to RUN-PROGRAM: ~S" object))))))))
(+ (* 1000 to-sec) (truncate to-usec 1000))
-1)
when (or #!+win32 (eq direction :output)
+ #!+win32 (sb!win32:handle-listen
+ (sb!win32:get-osfhandle fd))
+ #!-win32
(sb!unix:unix-simple-poll fd direction to-msec))
do (return-from wait-until-fd-usable t)
else
- do (when to-sec (maybe-update-timeout))))))))
+ do (when to-sec (maybe-update-timeout))
+ #!+win32 (sb!thread:thread-yield)))))))
\f
;;; Wait for up to timeout seconds for an event to happen. Make sure all
;;; pending events are processed before returning.
mode)))
(if (minusp fd)
(values nil (get-errno))
- (values fd (octets-to-string template-buffer)))))))
+ (values #!-win32 fd #!+win32 (sb!win32::duplicate-and-unwrap-fd fd)
+ (octets-to-string template-buffer)))))))
\f
;;;; timebits.h
(defconstant l_incr 1) ; to increment the file pointer
(defconstant l_xtnd 2) ; to extend the file size
+;; off_t is 32 bit on Windows, yet our functions support 64 bit seeks.
+(define-alien-type unix-offset
+ #!-win32 off-t
+ #!+win32 (signed 64))
+
;;; Is a stream interactive?
(defun unix-isatty (fd)
(declare (type unix-fd fd))
- (int-syscall ("[_]isatty" int) fd))
+ #!-win32 (int-syscall ("isatty" int) fd)
+ #!+win32 (sb!win32::windows-isatty fd))
(defun unix-lseek (fd offset whence)
"Unix-lseek accepts a file descriptor and moves the file pointer by
"
(declare (type unix-fd fd)
(type (integer 0 2) whence))
- (let ((result #!-win32
- (alien-funcall (extern-alien #!-largefile "lseek"
+ (let ((result
+ #!-win32
+ (alien-funcall (extern-alien #!-largefile "lseek"
#!+largefile "lseek_largefile"
(function off-t int off-t int))
- fd offset whence)
- #!+win32 (sb!win32:lseeki64 fd offset whence)))
+ fd offset whence)
+ #!+win32 (sb!win32:lseeki64 fd offset whence)))
(if (minusp result)
(values nil (get-errno))
(values result 0))))
(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)))
+ (sb!win32::windows-pipe))
;; 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
;;; Duplicate an existing file descriptor (given as the argument) and
;;; return it. If FD is not a valid file descriptor, NIL and an error
;;; number are returned.
+#!-win32
(defun unix-dup (fd)
(declare (type unix-fd fd))
- (int-syscall ("[_]dup" int) fd))
+ (int-syscall ("dup" int) fd))
;;; Terminate the current process with an optional error code. If
;;; successful, the call doesn't return. If unsuccessful, the call
(%extract-stat-results (addr buf))
name (addr buf))))
(defun unix-fstat (fd)
+ #!-win32
(declare (type unix-fd fd))
- (with-alien ((buf (struct wrapped_stat)))
- (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
- (%extract-stat-results (addr buf))
- fd (addr buf))))
+ (#!-win32 funcall #!+win32 sb!win32::call-with-crt-fd
+ (lambda (fd)
+ (with-alien ((buf (struct wrapped_stat)))
+ (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
+ (%extract-stat-results (addr buf))
+ fd (addr buf))))
+ fd))
#!-win32
(defun fd-type (fd)
--- /dev/null
+;;;; Windows API bindings not needed for cold initialization.
+(in-package "SB-WIN32")
+\f
+;;;; CreateProcess and surrounding data structures provide a way to implement
+;;;; RUN-PROGRAM while using handles rather than file descriptors.
+
+(define-alien-type process-information
+ (struct process-information
+ (process-handle handle)
+ (thread-handle handle)
+ (process-id dword)
+ (thread-id dword)))
+
+(define-alien-type startup-info
+ (struct startup-info
+ (cb dword)
+ (reserved1 system-string)
+ (desktop system-string)
+ (title system-string)
+ (x dword)
+ (y dword)
+ (x-size dword)
+ (y-size dword)
+ (x-chars dword)
+ (y-chars dword)
+ (fill-attribute dword)
+ (flags dword)
+ (show-window unsigned-short)
+ (reserved2 unsigned-short)
+ (reserved3 (* t))
+ (stdin handle)
+ (stdout handle)
+ (stderr handle)))
+
+(defconstant +startf-use-std-handles+ #x100)
+
+(define-alien-routine ("CreateProcessW" create-process) lispbool
+ (application-name system-string)
+ (command-line system-string)
+ (process-security-attributes (* t))
+ (thread-security-attributes (* t))
+ (inherit-handles-p lispbool)
+ (creation-flags dword)
+ (environment (* t))
+ (current-directory system-string)
+ (startup-info (* t))
+ (process-information (* t)))
+
+(defun search-path (partial-name)
+ "Searh executable using the system path"
+ (with-alien ((pathname-buffer pathname-buffer))
+ (syscall (("SearchPath" t) dword
+ system-string
+ system-string
+ system-string
+ dword
+ (* t)
+ (* t))
+ (and (plusp result)
+ (values (decode-system-string pathname-buffer) result))
+ nil partial-name nil
+ max_path (cast pathname-buffer (* char)) nil)))
+
+(define-alien-routine ("GetExitCodeProcess" get-exit-code-process) int
+ (handle handle) (exit-code dword :out))
+
+(define-alien-routine ("GetExitCodeThread" get-exit-code-thread) int
+ (handle handle) (exit-code dword :out))
+
+(defun mswin-spawn (program argv stdin stdout stderr searchp envp waitp)
+ (declare (ignorable envp))
+ (let ((std-handles (multiple-value-list (get-std-handles)))
+ (inheritp nil))
+ (flet ((maybe-std-handle (arg)
+ (let ((default (pop std-handles)))
+ (case arg (-1 default) (otherwise (setf inheritp t) arg)))))
+ (with-alien ((process-information process-information)
+ (startup-info startup-info))
+ (sb-kernel:system-area-ub8-fill
+ 0 (alien-sap startup-info)
+ 0 (alien-size startup-info :bytes))
+ (setf (slot startup-info 'cb) (alien-size startup-info :bytes)
+ (slot startup-info 'stdin) (maybe-std-handle stdin)
+ (slot startup-info 'stdout) (maybe-std-handle stdout)
+ (slot startup-info 'stderr) (maybe-std-handle stderr)
+ (slot startup-info 'reserved1) nil
+ (slot startup-info 'reserved2) 0
+ (slot startup-info 'reserved3) nil
+ (slot startup-info 'flags) (if inheritp +startf-use-std-handles+ 0))
+ (without-interrupts
+ ;; KLUDGE: pass null image file name when searchp is true.
+ ;; This way, file extension gets resolved by OS if omitted.
+ (if (create-process (if searchp nil program)
+ argv
+ nil nil
+ inheritp 0 nil nil
+ (alien-sap startup-info)
+ (alien-sap process-information))
+ (let ((child (slot process-information 'process-handle)))
+ (close-handle (slot process-information 'thread-handle))
+ (if waitp
+ (do () ((/= 1 (with-local-interrupts (wait-object-or-signal child)))
+ (multiple-value-bind (got code) (get-exit-code-process child)
+ (if got code -1))))
+ child))
+ -2))))))
;;;; File Handles
+;;; Historically, SBCL on Windows used CRT (lowio) file descriptors,
+;;; unlike other Lisps. They really help to minimize required effort
+;;; for porting Unix-specific software, at least to the level that it
+;;; mostly works most of the time.
+;;;
+;;; Alastair Bridgewater recommended to switch away from CRT
+;;; descriptors, and Anton Kovalenko thinks it's the time to heed his
+;;; advice. I see that SBCL for Windows needs much more effort in the
+;;; area of OS IO abstractions and the like; using or leaving lowio
+;;; FDs doesn't change the big picture so much.
+;;;
+;;; Lowio layer, in exchange for `semi-automatic almost-portability',
+;;; brings some significant problems, which a grown-up cross-platform
+;;; CL implementation shouldn't have. Therefore, as its benefits
+;;; become negligible, it's a good reason to throw it away.
+;;;
+;;; -- comment from AK's branch
+
+;;; For a few more releases, let's preserve old functions (now
+;;; implemented as identity) for user code which might have had to peek
+;;; into our internals in past versions when we hadn't been using
+;;; handles yet. -- DFL, 2012
+(defun get-osfhandle (fd) fd)
+(defun open-osfhandle (handle flags) (declare (ignore flags)) handle)
+
;;; Get the operating system handle for a C file descriptor. Returns
;;; INVALID-HANDLE on failure.
-(define-alien-routine ("_get_osfhandle" get-osfhandle) handle
+(define-alien-routine ("_get_osfhandle" real-get-osfhandle) handle
+ (fd int))
+
+(define-alien-routine ("_close" real-crt-close) int
(fd int))
;;; Read data from a file handle into a buffer. This may be used
(length dword)
(nevents (* dword)))
+(define-alien-routine ("socket_input_available" socket-input-available) int
+ (socket handle))
+
;;; Listen for input on a Windows file handle. Unlike UNIX, there
;;; isn't a unified interface to do this---we have to know what sort
;;; of handle we have. Of course, there's no way to actually
handle)))
(unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
(return-from handle-listen (plusp avail)))
-
- (unless (zerop (peek-console-input handle
- (cast buf (* t))
- 1 (addr avail)))
- (return-from handle-listen (plusp avail)))
-
- ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
- ;; HANDLE is a socket.
+ (let ((res (socket-input-available handle)))
+ (unless (zerop res)
+ (return-from handle-listen (= res 1))))
t))
;;; Listen for input on a C runtime file handle. Returns true if
(zerop (sb!impl::os-wait-for-wtimer timer)))))
(sb!impl::os-close-wtimer timer))))))
+(define-alien-routine ("win32_wait_object_or_signal" wait-object-or-signal)
+ (signed 16)
+ (handle handle))
+
#!+sb-unicode
(progn
(defvar *ansi-codepage* nil)
(defmacro make-system-buffer (x)
`(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
+(define-alien-type pathname-buffer
+ (array char #.(ash (1+ max_path) #!+sb-unicode 1 #!-sb-unicode 0)))
+
+(define-alien-type long-pathname-buffer
+ #!+sb-unicode (array char 65536)
+ #!-sb-unicode pathname-buffer)
+
;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
;;; macros in this file, are only used in this file, and could be
;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
(alien-funcall afunc aname (addr length))))
(cast-and-free aname))))
-(define-alien-routine ("_lseeki64" lseeki64)
- (signed 64)
- (fd int)
- (position (signed 64))
- (whence int))
-
(define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool
(handle handle)
(offset long-long)
(new-position long-long :out)
(whence dword))
+(defun lseeki64 (handle offset whence)
+ (multiple-value-bind (moved to-place)
+ (set-file-pointer-ex handle offset whence)
+ (if moved
+ (values to-place 0)
+ (values -1 (- (get-last-error))))))
+
;; File mapping support routines
(define-alien-routine (#!+sb-unicode "CreateFileMappingW"
#!-sb-unicode "CreateFileMappingA"
(defconstant file-flag-overlapped #x40000000)
(defconstant file-flag-sequential-scan #x8000000)
+;; Possible results of GetFileType.
+(defconstant file-type-disk 1)
+(defconstant file-type-char 2)
+(defconstant file-type-pipe 3)
+(defconstant file-type-remote 4)
+(defconstant file-type-unknown 0)
+
+(defconstant invalid-file-attributes (mod -1 (ash 1 32)))
+
+;;;; File Type Introspection by handle
+(define-alien-routine ("GetFileType" get-file-type) dword
+ (handle handle))
+
;; GetFileAttribute is like a tiny subset of fstat(),
;; enough to distinguish directories from anything else.
(define-alien-routine (#!+sb-unicode "GetFileAttributesW"
(define-alien-routine ("CloseHandle" close-handle) bool
(handle handle))
-(define-alien-routine ("_open_osfhandle" open-osfhandle)
+(define-alien-routine ("_open_osfhandle" real-open-osfhandle)
int
(handle handle)
(flags int))
;; -- DFL
;;
(set-file-pointer-ex handle 0 (if (plusp (logand sb!unix::o_append flags)) 2 0))
- (let ((fd (open-osfhandle handle (logior sb!unix::o_binary flags))))
- (if (minusp fd)
- (values nil (sb!unix::get-errno))
- (values fd 0))))))))
+ (values handle 0))))))
(define-alien-routine ("closesocket" close-socket) int (handle handle))
(define-alien-routine ("shutdown" shutdown-socket) int (handle handle)
;;; ...Seems to be the problem on some OSes, though. We could
;;; duplicate a handle and attempt close-socket on a duplicated one,
;;; but it also have some problems...
-;;;
-;;; For now, we protect socket handle from close with SetHandleInformation,
-;;; then call CRT _close() that fails to close a handle but _gets rid of fd_,
-;;; and then we close a handle ourserves.
(defun unixlike-close (fd)
- (let ((handle (get-osfhandle fd)))
- (flet ((close-protection (enable)
- (set-handle-information handle 2 (if enable 2 0))))
- (if (= handle invalid-handle)
- (values nil ebadf)
- (progn
- (when (and (socket-handle-p handle) (close-protection t))
- (shutdown-socket handle 2)
- (alien-funcall (extern-alien "_dup2" (function int int int)) 0 fd)
- (close-protection nil)
- (close-socket handle))
- (sb!unix::void-syscall ("_close" int) fd))))))
+ (if (or (zerop (close-socket fd))
+ (close-handle fd))
+ t (values nil ebadf)))
+
+(defconstant +std-input-handle+ -10)
+(defconstant +std-output-handle+ -11)
+(defconstant +std-error-handle+ -12)
+
+(defun get-std-handle-or-null (identity)
+ (let ((handle (alien-funcall
+ (extern-alien "GetStdHandle" (function handle dword))
+ (logand (1- (ash 1 (alien-size dword))) identity))))
+ (and (/= handle invalid-handle)
+ (not (zerop handle))
+ handle)))
+
+(defun get-std-handles ()
+ (values (get-std-handle-or-null +std-input-handle+)
+ (get-std-handle-or-null +std-output-handle+)
+ (get-std-handle-or-null +std-error-handle+)))
+
+(defconstant +duplicate-same-access+ 2)
+
+(defun duplicate-and-unwrap-fd (fd &key inheritp)
+ (let ((me (get-current-process)))
+ (multiple-value-bind (duplicated handle)
+ (duplicate-handle me (real-get-osfhandle fd)
+ me 0 inheritp +duplicate-same-access+)
+ (if duplicated
+ (prog1 handle (real-crt-close fd))
+ (win32-error 'duplicate-and-unwrap-fd)))))
+
+(define-alien-routine ("CreatePipe" create-pipe) lispbool
+ (read-pipe handle :out)
+ (write-pipe handle :out)
+ (security-attributes (* t))
+ (buffer-size dword))
+
+(defun windows-pipe ()
+ (multiple-value-bind (created read-handle write-handle)
+ (create-pipe nil 256)
+ (if created (values read-handle write-handle)
+ (win32-error 'create-pipe))))
+
+(defun windows-isatty (handle)
+ (if (= file-type-char (get-file-type handle))
+ 1 0))
+
+(defun inheritable-handle-p (handle)
+ (multiple-value-bind (got flags)
+ (get-handle-information handle)
+ (if got (plusp (logand flags +handle-flag-inherit+))
+ (win32-error 'inheritable-handle-p))))
+
+(defun (setf inheritable-handle-p) (allow handle)
+ (if (set-handle-information handle
+ +handle-flag-inherit+
+ (if allow +handle-flag-inherit+ 0))
+ allow
+ (win32-error '(setf inheritable-handle-p))))
+
+(defun sb!unix:unix-dup (fd)
+ (let ((me (get-current-process)))
+ (multiple-value-bind (duplicated handle)
+ (duplicate-handle me fd me 0 t +duplicate-same-access+)
+ (if duplicated
+ (values handle 0)
+ (values nil (- (get-last-error)))))))
+
+(defun call-with-crt-fd (thunk handle &optional (flags 0))
+ (multiple-value-bind (duplicate errno)
+ (sb!unix:unix-dup handle)
+ (if duplicate
+ (let ((fd (real-open-osfhandle duplicate flags)))
+ (unwind-protect (funcall thunk fd)
+ (real-crt-close fd)))
+ (values nil errno))))
"SRC;CODE;NTRACE"
"SRC;CODE;STEP"
"SRC;CODE;WARM-LIB"
+ #+win32 "SRC;CODE;WARM-MSWIN"
"SRC;CODE;RUN-PROGRAM"))
(let ((fullname (concatenate 'string "SYS:" stem ".LISP")))
AVERLAX(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE));
}
-#define maybe_open_osfhandle _open_osfhandle
-#define maybe_get_osfhandle _get_osfhandle
-#define FDTYPE int
-
/*
* os_map() is called to map a chunk of the core file into memory.
*
return buf;
}
+// 0 - not a socket or other error, 1 - has input, 2 - has no input
+int
+socket_input_available(HANDLE socket)
+{
+ unsigned long count = 0, count_size = 0;
+ int wsaErrno = GetLastError();
+ int err = WSAIoctl((SOCKET)socket, FIONREAD, NULL, 0,
+ &count, sizeof(count), &count_size, NULL, NULL);
+
+ int ret;
+
+ if (err == 0) {
+ ret = (count > 0) ? 1 : 2;
+ } else
+ ret = 0;
+ SetLastError(wsaErrno);
+ return ret;
+}
+
/* Unofficial but widely used property of console handles: they have
#b11 in two minor bits, opposed to other handles, that are
machine-word-aligned. Properly emulated even on wine.
static const LARGE_INTEGER zero_large_offset = {.QuadPart = 0LL};
int
-win32_unix_write(FDTYPE fd, void * buf, int count)
+win32_unix_write(HANDLE handle, void * buf, int count)
{
- HANDLE handle;
DWORD written_bytes;
OVERLAPPED overlapped;
struct thread * self = arch_os_get_current_thread();
BOOL seekable;
BOOL ok;
- handle =(HANDLE)maybe_get_osfhandle(fd);
if (console_handle_p(handle))
return win32_write_unicode_console(handle,buf,count);
}
int
-win32_unix_read(FDTYPE fd, void * buf, int count)
+win32_unix_read(HANDLE handle, void * buf, int count)
{
- HANDLE handle;
OVERLAPPED overlapped = {.Internal=0};
DWORD read_bytes = 0;
struct thread * self = arch_os_get_current_thread();
LARGE_INTEGER file_position;
BOOL seekable;
- handle = (HANDLE)maybe_get_osfhandle(fd);
-
if (console_handle_p(handle))
return win32_read_unicode_console(handle,buf,count);
projects / sbcl.git / commitdiff