X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=be0e22824945902fb1470e62f9e86b4e0c528d73;hb=8bb8f286dbacf1792a26de693c795d268516672c;hp=e6dfddf5912df2a1891bedee2712b3f1a10a3138;hpb=3598e49d52236b3992d4785605a732aa52776f85;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index e6dfddf..be0e228 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -47,7 +47,7 @@ ;;;; Lisp types used by syscalls -(deftype unix-pathname () 'simple-base-string) +(deftype unix-pathname () 'simple-string) (deftype unix-fd () `(integer 0 ,most-positive-fixnum)) (deftype unix-file-mode () '(unsigned-byte 32)) @@ -101,12 +101,21 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." `(let (,value ,errno) (loop (multiple-value-setq (,value ,errno) ,syscall-form) - (unless (eql ,errno sb!unix:eintr) + (unless #!-win32 (eql ,errno sb!unix:eintr) #!+win32 nil (return (values ,value ,errno)))) ,@body)) + +#!+win32 +(progn + (defconstant espipe 29) + ;; For stat-wrapper hack (different-type or non-existing win32 fields). + (define-alien-type nlink-t short) + (define-alien-type uid-t short) + (define-alien-type gid-t short)) ;;;; 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." @@ -116,6 +125,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)) @@ -157,7 +167,12 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (declare (type unix-pathname path) (type fixnum flags) (type unix-file-mode mode)) - (int-syscall ("open" c-string int int) path flags mode)) + (int-syscall ("open" c-string int int) + path + (logior #!+win32 o_binary + #!+largefile o_largefile + flags) + mode)) ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file ;;; associated with it. @@ -170,10 +185,19 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; 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. +#!-win32 +(define-alien-type nil + (struct timeval + (tv-sec time-t) ; seconds + (tv-usec suseconds-t))) ; and microseconds + +#!+win32 (define-alien-type nil - (struct timeval - (tv-sec time-t) ; seconds - (tv-usec time-t))) ; and microseconds + (struct timeval + (tv-sec time-t) ; seconds + (tv-usec long))) ; and microseconds ;;;; resourcebits.h @@ -212,6 +236,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. + +;;; 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)) @@ -237,7 +271,9 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." " (declare (type unix-fd fd) (type (integer 0 2) whence)) - (let ((result (alien-funcall (extern-alien "lseek" (function off-t int off-t int)) + (let ((result (alien-funcall (extern-alien #!-largefile "lseek" + #!+largefile "lseek_largefile" + (function off-t int off-t int)) fd offset whence))) (if (minusp result ) (values nil (get-errno)) @@ -275,16 +311,32 @@ 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 () (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)) - (void-syscall ("mkdir" c-string int) name mode)) + (type unix-file-mode mode) + #!+win32 (ignore mode)) + (void-syscall ("mkdir" c-string #!-win32 int) name #!-win32 mode)) ;;; Given a C char* pointer allocated by malloc(), free it and return a ;;; corresponding Lisp string (or return NIL if the pointer is a C NULL). @@ -298,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 @@ -311,14 +364,19 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; a constant. Going the grovel_headers route doesn't seem to be ;; helpful, either, as Solaris doesn't export PATH_MAX from ;; unistd.h. - #!-(or linux openbsd freebsd netbsd sunos osf1 darwin) (,stub,) - #!+(or linux openbsd freebsd netbsd sunos osf1 darwin) + ;; + ;; 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 "getcwd" (function (* char) (* char) size-t)) nil - #!+(or linux openbsd freebsd netbsd darwin) 0 + #!+(or linux openbsd freebsd netbsd darwin win32) 0 #!+(or sunos osf1) 1025)) (simple-perror "getcwd"))) @@ -327,22 +385,6 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun posix-getcwd/ () (concatenate 'string (posix-getcwd) "/")) -;;; Convert at the UNIX level from a possibly relative filename to -;;; an absolute filename. -;;; -;;; FIXME: Do we still need this even as we switch to -;;; *DEFAULT-PATHNAME-DEFAULTS*? I think maybe we do, since it seems -;;; to be valid for the user to set *DEFAULT-PATHNAME-DEFAULTS* to -;;; have a NIL directory component, and then this'd be the only way to -;;; interpret a relative directory specification. But I don't find the -;;; ANSI pathname documentation to be a model of clarity. Maybe -;;; someone who understands it better can take a look at this.. -- WHN -(defun unix-maybe-prepend-current-directory (name) - (declare (simple-string name)) - (if (and (> (length name) 0) (char= (schar name 0) #\/)) - name - (concatenate 'simple-string (posix-getcwd/) name))) - ;;; 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. @@ -361,9 +403,11 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (define-alien-routine ("getpid" unix-getpid) int) ;;; Return the real user id associated with the current process. +#!-win32 (define-alien-routine ("getuid" unix-getuid) int) ;;; Translate a user id into a login name. +#!-win32 (defun uid-username (uid) (or (newcharstar-string (alien-funcall (extern-alien "uid_username" (function (* char) int)) @@ -372,6 +416,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; Return the namestring of the home directory, being careful to ;;; include a trailing #\/ +#!-win32 (defun uid-homedir (uid) (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir" (function (* char) int)) @@ -381,6 +426,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; Invoke readlink(2) on the file name specified by PATH. Return ;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on ;;; failure. +#!-win32 (defun unix-readlink (path) (declare (type unix-pathname path)) (with-alien ((ptr (* char) @@ -394,6 +440,12 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (values (with-alien ((c-string c-string ptr)) c-string) nil) (free-alien ptr))))) +#!+win32 +;; Win32 doesn't do links, but something likes to call this anyway. +;; Something in this file, no less. But it only takes one result, so... +(defun unix-readlink (path) + (declare (ignore path)) + nil) ;;; UNIX-UNLINK accepts a name and deletes the directory entry for that ;;; name and the file if this is the last link. @@ -402,12 +454,14 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (void-syscall ("unlink" c-string) name)) ;;; Return the name of the host machine as a string. +#!-win32 (defun unix-gethostname () (with-alien ((buf (array char 256))) (syscall ("gethostname" (* char) int) (cast buf c-string) (cast buf (* char)) 256))) +#!-win32 (defun unix-setsid () (int-syscall ("setsid"))) @@ -416,6 +470,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; UNIX-IOCTL performs a variety of operations on open i/o ;;; descriptors. See the UNIX Programmer's Manual for more ;;; information. +#!-win32 (defun unix-ioctl (fd cmd arg) (declare (type unix-fd fd) (type (signed-byte 32) cmd)) @@ -429,6 +484,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; user time, and returns the seconds and microseconds as separate ;;; values. #!-sb-fluid (declaim (inline unix-fast-getrusage)) +#!-win32 (defun unix-fast-getrusage (who) (declare (values (member t) (unsigned-byte 31) (integer 0 1000000) @@ -447,6 +503,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; (rusage_self) or all of the terminated child processes ;;; (rusage_children). NIL and an error number is returned if the call ;;; fails. +#!-win32 (defun unix-getrusage (who) (with-alien ((usage (struct rusage))) (syscall ("getrusage" int (* (struct rusage))) @@ -573,23 +630,19 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; longer than 32 bits anyway, right?":-| (define-alien-type nil (struct wrapped_stat - #!-mips - (st-dev unsigned-int) ; would be dev-t in a real stat - #!+mips - (st-dev unsigned-long) ; this is _not_ a dev-t on mips + (st-dev #!-(or mips largefile) unsigned-int + #!+mips unsigned-long + #!+largefile dev-t) (st-ino ino-t) (st-mode mode-t) (st-nlink nlink-t) (st-uid uid-t) (st-gid gid-t) - #!-mips - (st-rdev unsigned-int) ; would be dev-t in a real stat - #!+mips - (st-rdev unsigned-long) ; this is _not_ a dev-t on mips - #!-mips - (st-size unsigned-int) ; would be off-t in a real stat - #!+mips - (st-size off-t) + (st-rdev #!-(or mips largefile) unsigned-int + #!+mips unsigned-long + #!+largefile dev-t) + (st-size #!-(or mips largefile) unsigned-int + #!+(or mips largefile) off-t) (st-blksize unsigned-long) (st-blocks unsigned-long) (st-atime time-t) @@ -680,6 +733,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (seconds-west sb!alien:int :out) (daylight-savings-p sb!alien:boolean :out)) +#!-win32 (defun nanosleep (secs nsecs) (with-alien ((req (struct timespec)) (rem (struct timespec))) @@ -736,6 +790,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defconstant itimer-virtual 1) (defconstant itimer-prof 2) +#!-win32 (defun unix-getitimer (which) "Unix-getitimer returns the INTERVAL and VALUE slots of one of three system timers (:real :virtual or :profile). On success, @@ -758,6 +813,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (slot (slot itv 'it-value) 'tv-usec)) which (alien-sap (addr itv)))))) +#!-win32 (defun unix-setitimer (which int-secs int-usec val-secs val-usec) " Unix-setitimer sets the INTERVAL and VALUE slots of one of three system timers (:real :virtual or :profile). A SIGALRM signal @@ -804,7 +860,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun unix-file-kind (name &optional check-for-links) #!+sb-doc "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL." - (declare (simple-base-string name)) + (declare (simple-string name)) (multiple-value-bind (res dev ino mode) (if check-for-links (unix-lstat name) (unix-stat name)) (declare (type (or fixnum null) mode) @@ -813,6 +869,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (let ((kind (logand mode s-ifmt))) (cond ((eql kind s-ifdir) :directory) ((eql kind s-ifreg) :file) + #!-win32 ((eql kind s-iflnk) :link) (t :special)))))) @@ -829,13 +886,21 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; paths have been converted to absolute paths, so we don't need to ;;; try to handle any more generality than that. (defun unix-resolve-links (pathname) - (declare (type simple-base-string pathname)) + (declare (type simple-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 @@ -854,14 +919,14 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (if (null link) (return pathname) (let ((new-pathname - (unix-simplify-pathname + (simplify-namestring (if (relative-unix-pathname? link) (let* ((dir-len (1+ (position #\/ pathname :from-end t))) (dir (subseq pathname 0 dir-len))) (/noshow dir) - (concatenate 'base-string dir link)) + (concatenate 'string dir link)) link)))) (if (unix-file-kind new-pathname) (setf pathname new-pathname) @@ -875,92 +940,41 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (if (member pathname previous-pathnames :test #'string=) (return pathname) (push pathname previous-pathnames)))) - -(defun unix-simplify-pathname (src) - (declare (type simple-base-string src)) - (let* ((src-len (length src)) - (dst (make-string src-len :element-type 'base-char)) - (dst-len 0) - (dots 0) - (last-slash nil)) - (macrolet ((deposit (char) - `(progn - (setf (schar dst dst-len) ,char) - (incf dst-len)))) - (dotimes (src-index src-len) - (let ((char (schar src src-index))) - (cond ((char= char #\.) - (when dots - (incf dots)) - (deposit char)) - ((char= char #\/) - (case dots - (0 - ;; either ``/...' or ``...//...' - (unless last-slash - (setf last-slash dst-len) - (deposit char))) - (1 - ;; either ``./...'' or ``..././...'' - (decf dst-len)) - (2 - ;; We've found .. - (cond - ((and last-slash (not (zerop last-slash))) - ;; There is something before this .. - (let ((prev-prev-slash - (position #\/ dst :end last-slash :from-end t))) - (cond ((and (= (+ (or prev-prev-slash 0) 2) - last-slash) - (char= (schar dst (- last-slash 2)) #\.) - (char= (schar dst (1- last-slash)) #\.)) - ;; The something before this .. is another .. - (deposit char) - (setf last-slash dst-len)) - (t - ;; The something is some directory or other. - (setf dst-len - (if prev-prev-slash - (1+ prev-prev-slash) - 0)) - (setf last-slash prev-prev-slash))))) - (t - ;; There is nothing before this .., so we need to keep it - (setf last-slash dst-len) - (deposit char)))) - (t - ;; something other than a dot between slashes - (setf last-slash dst-len) - (deposit char))) - (setf dots 0)) - (t - (setf dots nil) - (setf (schar dst dst-len) char) - (incf dst-len)))))) - (when (and last-slash (not (zerop last-slash))) - (case dots - (1 - ;; We've got ``foobar/.'' - (decf dst-len)) - (2 - ;; We've got ``foobar/..'' - (unless (and (>= last-slash 2) - (char= (schar dst (1- last-slash)) #\.) - (char= (schar dst (- last-slash 2)) #\.) - (or (= last-slash 2) - (char= (schar dst (- last-slash 3)) #\/))) - (let ((prev-prev-slash - (position #\/ dst :end last-slash :from-end t))) - (if prev-prev-slash - (setf dst-len (1+ prev-prev-slash)) - (return-from unix-simplify-pathname - (coerce "./" 'simple-base-string)))))))) - (cond ((zerop dst-len) - "./") - ((= dst-len src-len) - dst) - (t - (subseq dst 0 dst-len))))) + +;;; UNIX specific code, that has been cleanly separated from the +;;; Windows build. +#!-win32 +(progn + (defconstant micro-seconds-per-internal-time-unit + (/ 1000000 sb!xc:internal-time-units-per-second)) + + (declaim (inline system-internal-real-time system-internal-run-time)) + (defun system-internal-real-time () + (multiple-value-bind (ignore seconds useconds) (unix-gettimeofday) + (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds)) + (let ((uint (truncate useconds + micro-seconds-per-internal-time-unit))) + (declare (type (unsigned-byte 32) uint)) + (+ (* seconds sb!xc:internal-time-units-per-second) + uint)))) + + (defun system-internal-run-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) + ;; (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)) + (let ((result (+ (* (+ utime-sec stime-sec) + sb!xc:internal-time-units-per-second) + (floor (+ utime-usec + stime-usec + (floor micro-seconds-per-internal-time-unit 2)) + micro-seconds-per-internal-time-unit)))) + result)))) ;;;; A magic constant for wait3(). ;;;; @@ -1013,3 +1027,4 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." `(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)))) +