X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=b7a30c80d412d42b2d5e8b17657dd3e014873dc3;hb=03e8baab974e52e86df105ee269e83efd65e3d8e;hp=d5ac4836b72c5d6c813d181c199d687ee7fc4913;hpb=bb3994fcc9a556d1a26d35f6ff9386d01030821d;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index d5ac483..b7a30c8 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -62,6 +62,9 @@ ;;; 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)) @@ -133,7 +136,7 @@ corresponds to NAME, or NIL if there is none." ;;; 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 @@ -158,6 +161,8 @@ corresponds to NAME, or NIL if there is none." (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 @@ -170,8 +175,9 @@ corresponds to NAME, or NIL if there is none." ;;; 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)) ;;;; stdlib.h @@ -194,7 +200,8 @@ corresponds to NAME, or NIL if there is none." 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))))))) ;;;; timebits.h @@ -273,17 +280,24 @@ corresponds to NAME, or NIL if there is none." (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 @@ -295,10 +309,13 @@ corresponds to NAME, or NIL if there is none." " (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)))) @@ -314,7 +331,8 @@ corresponds to NAME, or NIL if there is none." (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 @@ -325,7 +343,8 @@ corresponds to NAME, or NIL if there is none." (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))) @@ -348,15 +367,10 @@ corresponds to NAME, or NIL if there is none." (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 @@ -396,11 +410,10 @@ corresponds to NAME, or NIL if there is none." ;; 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) @@ -419,6 +432,7 @@ corresponds to NAME, or NIL if there is none." ;;; 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)) @@ -426,12 +440,23 @@ corresponds to NAME, or NIL if there is none." ;;; 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 @@ -503,7 +528,7 @@ corresponds to NAME, or NIL if there is none." ;;; 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 @@ -875,11 +900,40 @@ corresponds to NAME, or NIL if there is none." (%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)))) ;;;; time.h @@ -924,8 +978,8 @@ corresponds to NAME, or NIL if there is none." (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)) @@ -950,10 +1004,12 @@ corresponds to NAME, or NIL if there is none." (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)