;;; should live in SB-SYS or even SB-EXT?
(defmacro syscall ((name &rest arg-types) success-form &rest args)
+ (when (eql 3 (mismatch "[_]" name))
+ (setf name
+ (concatenate 'string #!+win32 "_" (subseq name 3))))
`(locally
(declare (optimize (sb!c::float-accuracy 0)))
(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
;;; is not extreme enough, since it doesn't need to be blindingly
;;; fast: we can just implement those functions in C as a wrapper
;;; layer.
-(define-alien-type fd-mask unsigned-long)
+(define-alien-type fd-mask unsigned)
(define-alien-type nil
(struct fd-set
(declare (type unix-pathname path)
(type fixnum flags)
(type unix-file-mode mode))
+ #!+win32 (sb!win32:unixlike-open path flags mode)
+ #!-win32
(with-restarted-syscall (value errno)
(int-syscall ("open" c-string int int)
path
;;; associated with it.
(/show0 "unix.lisp 391")
(defun unix-close (fd)
- (declare (type unix-fd fd))
- (void-syscall ("close" int) fd))
+ #!+win32 (sb!win32:unixlike-close fd)
+ #!-win32 (declare (type unix-fd fd))
+ #!-win32 (void-syscall ("close" int) fd))
\f
;;;; stdlib.h
mode)))
(if (minusp fd)
(values nil (get-errno))
- (values fd (octets-to-string template-buffer)))))))
-\f
-;;;; timebits.h
-
-;; A time value that is accurate to the nearest
-;; microsecond but also has a range of years.
-;; CLH: Note that tv-usec used to be a time-t, but that this seems
-;; problematic on Darwin x86-64 (and wrong). Trying suseconds-t.
-#!-(or win32 openbsd netbsd)
-(define-alien-type nil
- (struct timeval
- (tv-sec time-t) ; seconds
- (tv-usec suseconds-t))) ; and microseconds
-
-;; The above definition doesn't work on 64-bit OpenBSD platforms.
-;; Both tv_sec and tv_usec are declared as long instead of time_t, and
-;; time_t is a typedef for int.
-#!+(or openbsd netbsd)
-(define-alien-type nil
- (struct timeval
- (tv-sec long) ; seconds
- (tv-usec long))) ; and microseconds
-
-#!+win32
-(define-alien-type nil
- (struct timeval
- (tv-sec time-t) ; seconds
- (tv-usec long))) ; and microseconds
+ (values #!-win32 fd #!+win32 (sb!win32::duplicate-and-unwrap-fd fd)
+ (octets-to-string template-buffer)))))))
\f
;;;; resourcebits.h
(defun unix-access (path mode)
(declare (type unix-pathname path)
(type (mod 8) mode))
- (void-syscall ("access" c-string int) path mode))
+ (void-syscall ("[_]access" c-string int) path mode))
;;; values for the second argument to UNIX-LSEEK
+;;; Note that nowadays these are called SEEK_SET, SEEK_CUR, and SEEK_END
(defconstant l_set 0) ; to set the file pointer
(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 (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)))
+ fd offset whence)
+ #!+win32 (sb!win32:lseeki64 fd offset whence)))
(if (minusp result)
(values nil (get-errno))
(values result 0))))
(defun unix-read (fd buf len)
(declare (type unix-fd fd)
(type (unsigned-byte 32) len))
- (int-syscall ("read" int (* char) int) fd buf len))
+ (int-syscall (#!-win32 "read" #!+win32 "win32_unix_read"
+ int (* char) int) fd buf len))
;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the
;;; length to write. It attempts to write len bytes to the device
(type (unsigned-byte 32) offset len))
(flet ((%write (sap)
(declare (system-area-pointer sap))
- (int-syscall ("write" int (* char) int)
+ (int-syscall (#!-win32 "write" #!+win32 "win32_unix_write"
+ int (* char) int)
fd
(with-alien ((ptr (* char) sap))
(addr (deref ptr offset)))
(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
;; helpful, either, as Solaris doesn't export PATH_MAX from
;; unistd.h.
;;
- ;; FIXME: The (,stub,) nastiness produces an error message about a
- ;; comma not inside a backquote. This error has absolutely nothing
- ;; to do with the actual meaning of the error (and little to do with
- ;; its location, either).
- #!-(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32) (,stub,)
+ ;; Signal an error at compile-time, since it's needed for the
+ ;; runtime to start up
+ #!-(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32)
+ #.(error "POSIX-GETCWD is not implemented.")
#!+(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32)
(or (newcharstar-string (alien-funcall (extern-alien "getcwd"
(function (* char)
;;; 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))
;;; Terminate the current process with an optional error code. If
;;; successful, the call doesn't return. If unsuccessful, the call
;;; returns NIL and an error number.
-(defun unix-exit (&optional (code 0))
- (declare (type (signed-byte 32) code))
- (void-syscall ("exit" int) code))
+(deftype exit-code ()
+ `(signed-byte 32))
+(defun os-exit (code &key abort)
+ #!+sb-doc
+ "Exit the process with CODE. If ABORT is true, exit is performed using _exit(2),
+avoiding atexit(3) hooks, etc. Otherwise exit(2) is called."
+ (unless (typep code 'exit-code)
+ (setf code (if abort 1 0)))
+ (if abort
+ (void-syscall ("_exit" int) code)
+ (void-syscall ("exit" int) code)))
+
+(define-deprecated-function :early "1.0.56.55" unix-exit os-exit (code)
+ (os-exit code))
;;; Return the process id of the current process.
-(define-alien-routine ("getpid" unix-getpid) int)
+(define-alien-routine (#!+win32 "_getpid" #!-win32 "getpid" unix-getpid) int)
;;; Return the real user id associated with the current process.
#!-win32
;;; name and the file if this is the last link.
(defun unix-unlink (name)
(declare (type unix-pathname name))
- (void-syscall ("unlink" c-string) name))
+ (void-syscall ("[_]unlink" c-string) name))
;;; Return the name of the host machine as a string.
#!-win32
#!-win32
(defun unix-fast-getrusage (who)
(declare (values (member t)
- (unsigned-byte 31) (integer 0 1000000)
- (unsigned-byte 31) (integer 0 1000000)))
+ unsigned-byte fixnum
+ unsigned-byte fixnum))
(with-alien ((usage (struct rusage)))
- (syscall* ("getrusage" int (* (struct rusage)))
+ (syscall* ("sb_getrusage" int (* (struct rusage)))
(values t
(slot (slot usage 'ru-utime) 'tv-sec)
(slot (slot usage 'ru-utime) 'tv-usec)
#!-win32
(defun unix-getrusage (who)
(with-alien ((usage (struct rusage)))
- (syscall ("getrusage" int (* (struct rusage)))
+ (syscall ("sb_getrusage" int (* (struct rusage)))
(values t
(+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000)
(slot (slot usage 'ru-utime) 'tv-usec))
`(let ((,n (if (< 0 ,n fd-setsize)
,n
(error "Cannot select(2) on ~D: above FD_SETSIZE limit."
- (1- num-descriptors)))))
+ (1- ,n)))))
(declare (type (integer 0 #.fd-setsize) ,n))
,@body))
(type (or null (unsigned-byte 31)) timeout-secs timeout-usecs))
(with-fd-setsize (num-descriptors)
(flet ((select (tv-sap)
- (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
+ (int-syscall ("sb_select" int (* (struct fd-set)) (* (struct fd-set))
(* (struct fd-set)) (* (struct timeval)))
num-descriptors read-fds write-fds exception-fds
tv-sap)))
;;; UNIX-SELECT accepts sets of file descriptors and waits for an event
;;; to happen on one of them or to time out.
-(defmacro num-to-fd-set (fdset num)
- `(if (fixnump ,num)
- (progn
- (setf (deref (slot ,fdset 'fds-bits) 0) ,num)
- ,@(loop for index upfrom 1 below (/ fd-setsize
- sb!vm:n-machine-word-bits)
- collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
- (progn
- ,@(loop for index upfrom 0 below (/ fd-setsize
- sb!vm:n-machine-word-bits)
- collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
- (ldb (byte sb!vm:n-machine-word-bits
- ,(* index sb!vm:n-machine-word-bits))
- ,num))))))
-
-(defmacro fd-set-to-num (nfds fdset)
- `(if (<= ,nfds sb!vm:n-machine-word-bits)
- (deref (slot ,fdset 'fds-bits) 0)
- (+ ,@(loop for index upfrom 0 below (/ fd-setsize
- sb!vm:n-machine-word-bits)
- collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
- ,(* index sb!vm:n-machine-word-bits))))))
+(declaim (inline num-to-fd-set fd-set-to-num))
+(defun num-to-fd-set (fdset num)
+ (typecase num
+ (fixnum
+ (setf (deref (slot fdset 'fds-bits) 0) num)
+ (loop for index from 1 below (/ fd-setsize
+ sb!vm:n-machine-word-bits)
+ do (setf (deref (slot fdset 'fds-bits) index) 0)))
+ (t
+ (loop for index from 0 below (/ fd-setsize
+ sb!vm:n-machine-word-bits)
+ do (setf (deref (slot fdset 'fds-bits) index)
+ (ldb (byte sb!vm:n-machine-word-bits
+ (* index sb!vm:n-machine-word-bits))
+ num))))))
+
+(defun fd-set-to-num (nfds fdset)
+ (if (<= nfds sb!vm:n-machine-word-bits)
+ (deref (slot fdset 'fds-bits) 0)
+ (loop for index below (/ fd-setsize
+ sb!vm:n-machine-word-bits)
+ sum (ash (deref (slot fdset 'fds-bits) index)
+ (* index sb!vm:n-machine-word-bits)))))
;;; Examine the sets of descriptors passed as arguments to see whether
;;; they are ready for reading and writing. See the UNIX Programmer's
(type unsigned-byte rdfds wrfds xpfds)
(type (or (unsigned-byte 31) null) to-secs)
(type (unsigned-byte 31) to-usecs)
- (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
+ (optimize (speed 3) (safety 0)))
(with-fd-setsize (nfds)
(with-alien ((tv (struct timeval))
(rdf (struct fd-set))
`(if (zerop ,lispvar)
(int-sap 0)
(alien-sap (addr ,alienvar)))))
- (syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
+ (syscall ("sb_select" int (* (struct fd-set)) (* (struct fd-set))
(* (struct fd-set)) (* (struct timeval)))
(values result
(fd-set-to-num nfds rdf)
nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf)
(if to-secs (alien-sap (addr tv)) (int-sap 0)))))))
-;;; Lisp-side implmentations of FD_FOO macros. Abandon all hope who enters
-;;; here...
-;;;
-(defmacro fd-set (offset fd-set)
- (with-unique-names (word bit)
- `(multiple-value-bind (,word ,bit) (floor ,offset
- sb!vm:n-machine-word-bits)
- (setf (deref (slot ,fd-set 'fds-bits) ,word)
- (logior (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
- (ash 1 ,bit))
- (deref (slot ,fd-set 'fds-bits) ,word))))))
-
-(defmacro fd-clr (offset fd-set)
- (with-unique-names (word bit)
- `(multiple-value-bind (,word ,bit) (floor ,offset
- sb!vm:n-machine-word-bits)
- (setf (deref (slot ,fd-set 'fds-bits) ,word)
- (logand (deref (slot ,fd-set 'fds-bits) ,word)
- (sb!kernel:word-logical-not
- (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
- (ash 1 ,bit))))))))
-
-(defmacro fd-isset (offset fd-set)
- (with-unique-names (word bit)
- `(multiple-value-bind (,word ,bit) (floor ,offset
- sb!vm:n-machine-word-bits)
- (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
-
-(defmacro fd-zero (fd-set)
- `(progn
- ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits)
- collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
+;;; Lisp-side implmentations of FD_FOO macros.
+(declaim (inline fd-set fd-clr fd-isset fd-zero))
+(defun fd-set (offset fd-set)
+ (multiple-value-bind (word bit) (floor offset
+ sb!vm:n-machine-word-bits)
+ (setf (deref (slot fd-set 'fds-bits) word)
+ (logior (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
+ (ash 1 bit))
+ (deref (slot fd-set 'fds-bits) word)))))
+
+(defun fd-clr (offset fd-set)
+ (multiple-value-bind (word bit) (floor offset
+ sb!vm:n-machine-word-bits)
+ (setf (deref (slot fd-set 'fds-bits) word)
+ (logand (deref (slot fd-set 'fds-bits) word)
+ (sb!kernel:word-logical-not
+ (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
+ (ash 1 bit)))))))
+
+(defun fd-isset (offset fd-set)
+ (multiple-value-bind (word bit) (floor offset
+ sb!vm:n-machine-word-bits)
+ (logbitp bit (deref (slot fd-set 'fds-bits) word))))
+
+(defun fd-zero (fd-set)
+ (loop for index below (/ fd-setsize sb!vm:n-machine-word-bits)
+ do (setf (deref (slot fd-set 'fds-bits) index) 0)))
#!-os-provides-poll
(defun unix-simple-poll (fd direction to-msec)
(%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)
+ (declare (type unix-fd fd))
+ (let ((fmt (logand
+ sb!unix:s-ifmt
+ (or (with-alien ((buf (struct wrapped_stat)))
+ (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
+ (slot buf 'st-mode)
+ fd (addr buf)))
+ 0))))
+ (cond ((logtest sb!unix:s-ififo fmt)
+ :fifo)
+ ((logtest sb!unix:s-ifchr fmt)
+ :character)
+ ((logtest sb!unix:s-ifdir fmt)
+ :directory)
+ ((logtest sb!unix:s-ifblk fmt)
+ :block)
+ ((logtest sb!unix:s-ifreg fmt)
+ :regular)
+ ((logtest sb!unix:s-ifsock fmt)
+ :socket)
+ (t
+ :unknown))))
\f
;;;; time.h
-;; the POSIX.4 structure for a time value. This is like a "struct
-;; timeval" but has nanoseconds instead of microseconds.
-#!-(or openbsd netbsd)
-(define-alien-type nil
- (struct timespec
- (tv-sec long) ; seconds
- (tv-nsec long))) ; nanoseconds
-
-;; Just as with struct timeval, 64-bit OpenBSD has problems with the
-;; above definition. tv_sec is declared as time_t instead of long,
-;; and time_t is a typedef for int.
-#!+(or openbsd netbsd)
-(define-alien-type nil
- (struct timespec
- (tv-sec time-t) ; seconds
- (tv-nsec long))) ; nanoseconds
-
;; used by other time functions
(define-alien-type nil
(struct tm
(defun nanosleep (secs nsecs)
(with-alien ((req (struct timespec))
(rem (struct timespec)))
- (setf (slot req 'tv-sec) secs)
- (setf (slot req 'tv-nsec) nsecs)
+ (setf (slot req 'tv-sec) secs
+ (slot req 'tv-nsec) nsecs)
(loop while (and (eql sb!unix:eintr
(nth-value 1
- (int-syscall ("nanosleep" (* (struct timespec))
+ (int-syscall ("sb_nanosleep" (* (struct timespec))
(* (struct timespec)))
(addr req) (addr rem))))
;; KLUDGE: On Darwin, if an interrupt cases nanosleep to
(rem-nsec (slot rem 'tv-nsec)))
(when (or (> secs rem-sec)
(and (= secs rem-sec) (>= nsecs rem-nsec)))
- (setf secs rem-sec
+ ;; Update for next round.
+ (setf secs rem-sec
nsecs rem-nsec)
t)))
- do (rotatef req rem))))
+ do (setf (slot req 'tv-sec) (slot rem 'tv-sec)
+ (slot req 'tv-nsec) (slot rem 'tv-nsec)))))
(defun unix-get-seconds-west (secs)
(multiple-value-bind (ignore seconds dst) (get-timezone secs)
T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec."
(declare (type (member :real :virtual :profile) which)
(values t
- (unsigned-byte 29) (mod 1000000)
- (unsigned-byte 29) (mod 1000000)))
+ unsigned-byte (mod 1000000)
+ unsigned-byte (mod 1000000)))
(let ((which (ecase which
(:real itimer-real)
(:virtual itimer-virtual)
(:profile itimer-prof))))
(with-alien ((itv (struct itimerval)))
- (syscall* ("getitimer" int (* (struct itimerval)))
+ (syscall* ("sb_getitimer" int (* (struct itimerval)))
(values t
(slot (slot itv 'it-interval) 'tv-sec)
(slot (slot itv 'it-interval) 'tv-usec)
unix-setitimer returns the old contents of the INTERVAL and VALUE
slots as in unix-getitimer."
(declare (type (member :real :virtual :profile) which)
- (type (unsigned-byte 29) int-secs val-secs)
+ (type unsigned-byte int-secs val-secs)
(type (integer 0 (1000000)) int-usec val-usec)
(values t
- (unsigned-byte 29) (mod 1000000)
- (unsigned-byte 29) (mod 1000000)))
+ unsigned-byte (mod 1000000)
+ unsigned-byte (mod 1000000)))
(let ((which (ecase which
(:real itimer-real)
(:virtual itimer-virtual)
(slot (slot itvn 'it-interval) 'tv-usec) int-usec
(slot (slot itvn 'it-value ) 'tv-sec ) val-secs
(slot (slot itvn 'it-value ) 'tv-usec) val-usec)
- (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
+ (syscall* ("sb_setitimer" int (* (struct timeval))(* (struct timeval)))
(values t
(slot (slot itvo 'it-interval) 'tv-sec)
(slot (slot itvo 'it-interval) 'tv-usec)
(defun get-time-of-day ()
"Return the number of seconds and microseconds since the beginning of
the UNIX epoch (January 1st 1970.)"
- #!+darwin
+ #!+(or darwin netbsd)
(with-alien ((tv (struct timeval)))
;; CLH: FIXME! This seems to be a MacOS bug, but on x86-64/darwin,
;; gettimeofday occasionally fails. passing in a null pointer for the
;; timezone struct seems to work around the problem. NS notes: Darwin
;; manpage says the timezone is not used anymore in their implementation
;; at all.
- (syscall* ("gettimeofday" (* (struct timeval))
+ (syscall* ("sb_gettimeofday" (* (struct timeval))
(* (struct timezone)))
(values (slot tv 'tv-sec)
(slot tv 'tv-usec))
(addr tv)
nil))
- #!-(and x86-64 darwin)
+ #!-(or darwin netbsd)
(with-alien ((tv (struct timeval))
(tz (struct timezone)))
- (syscall* ("gettimeofday" (* (struct timeval))
+ (syscall* ("sb_gettimeofday" (* (struct timeval))
(* (struct timezone)))
(values (slot tv 'tv-sec)
(slot tv 'tv-usec))
(defun system-real-time-values ()
(multiple-value-bind (sec usec) (get-time-of-day)
- (declare (type (unsigned-byte 32) sec usec))
+ (declare (type unsigned-byte sec) (type (unsigned-byte 31) usec))
(values sec (truncate usec micro-seconds-per-internal-time-unit))))
;; There are two optimizations here that actually matter (on 32-bit
(c-sec 0)
(c-msec 0)
(now 0))
- (declare (type (unsigned-byte 32) e-sec c-sec)
+ (declare (type unsigned-byte e-sec c-sec)
(type fixnum e-msec c-msec)
(type unsigned-byte now))
(defun reinit-internal-real-time ()
(multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
(unix-fast-getrusage rusage_self)
(declare (ignore ignore)
- (type (unsigned-byte 31) utime-sec stime-sec)
+ (type unsigned-byte utime-sec stime-sec)
;; (Classic CMU CL had these (MOD 1000000) instead, but
;; at least in Linux 2.2.12, the type doesn't seem to
;; be documented anywhere and the observed behavior is
;; to sometimes return 1000000 exactly.)
- (type (integer 0 1000000) utime-usec stime-usec))
+ (type fixnum utime-usec stime-usec))
(let ((result (+ (* (+ utime-sec stime-sec)
sb!xc:internal-time-units-per-second)
(floor (+ utime-usec
projects / sbcl.git / blobdiff