X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=b7a30c80d412d42b2d5e8b17657dd3e014873dc3;hb=829ced3e78a23ba153ba4db64e6ea6984c2313b6;hp=ed7be907199e4f1def5fc7c591d38c68b9f50cf9;hpb=7572e0506af331534e6f97b027d56e8bea09410c;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index ed7be90..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 @@ -197,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 @@ -276,7 +280,7 @@ 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 @@ -284,10 +288,16 @@ corresponds to NAME, or NIL if there is none." (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 @@ -299,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)))) @@ -354,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 @@ -402,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) @@ -425,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)) @@ -448,7 +456,7 @@ avoiding atexit(3) hooks, etc. Otherwise exit(2) is called." (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 @@ -520,7 +528,7 @@ avoiding atexit(3) hooks, etc. Otherwise exit(2) is called." ;;; 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 @@ -892,11 +900,15 @@ avoiding atexit(3) hooks, etc. Otherwise exit(2) is called." (%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)