0.9.13.22:

[sbcl.git] / src / code / unix.lisp

diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index af55732..d6290d8 100644 (file)
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -47,7 +47,7 @@
 \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))
@@ -134,6 +134,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
 \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."
@@ -143,6 +144,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
 
 ;;; 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))
@@ -239,7 +241,16 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
 ;;;   w_ok     Write permission.
 ;;;   x_ok     Execute permission.
 ;;;   f_ok     Presence of file.
-#!-win32
+
+;;; In Windows, the MODE argument to access is defined in terms of
+;;; literal magic numbers---there are no constants to grovel.  X_OK
+;;; is not defined.
+#!+win32
+(progn
+  (defconstant f_ok 0)
+  (defconstant w_ok 2)
+  (defconstant r_ok 4))
+
 (defun unix-access (path mode)
   (declare (type unix-pathname path)
            (type (mod 8) mode))
@@ -303,17 +314,24 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
 ;;; 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)
@@ -332,6 +350,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
 
 ;;; 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
@@ -346,17 +365,13 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
   ;; helpful, either, as Solaris doesn't export PATH_MAX from
   ;; unistd.h.
   ;;
-  ;; The Win32 damage here is explained in the comment above wrap_getcwd()
-  ;; in src/runtime/wrap.c. Short form: We need it now, it goes away later.
-  ;;
   ;; 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 win32) (,stub,)
   #!+(or linux openbsd freebsd netbsd sunos osf1 darwin win32)
-  (or (newcharstar-string (alien-funcall (extern-alien #!-win32 "getcwd"
-                                                       #!+win32 "wrap_getcwd"
+  (or (newcharstar-string (alien-funcall (extern-alien "getcwd"
                                                        (function (* char)
                                                                  (* char)
                                                                  size-t))
@@ -876,12 +891,20 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
 ;;; try to handle any more generality than that.
 (defun unix-resolve-links (pathname)
   (declare (type simple-base-string pathname))
+  ;; KLUDGE: The Win32 platform doesn't have symbolic links, so
+  ;; short-cut this computation (and the check for being an absolute
+  ;; unix pathname...)
+  #!+win32 (return-from unix-resolve-links pathname)
   (aver (not (relative-unix-pathname? pathname)))
   ;; KLUDGE: readlink and lstat are unreliable if given symlinks
   ;; ending in slashes -- fix the issue here instead of waiting for
   ;; libc to change...
+  ;;
+  ;; but be careful!  Must not strip the final slash from "/".  (This
+  ;; adjustment might be a candidate for being transferred into the C
+  ;; code in a wrap_readlink() function, too.) CSR, 2006-01-18
   (let ((len (length pathname)))
-    (when (and (plusp len) (eql #\/ (schar pathname (1- len))))
+    (when (and (> len 1) (eql #\/ (schar pathname (1- len))))
       (setf pathname (subseq pathname 0 (1- len)))))
   (/noshow "entering UNIX-RESOLVE-LINKS")
   (loop with previous-pathnames = nil do