X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=e7cd25e10cf50e03ea739f740f9b9c747e12ce9f;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=c3c97a3492231e1da30c8f6ac3bdd41e7effa91a;hpb=d63d80e637e9058ff5db7a10c267796ff7970ba1;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index c3c97a3..e7cd25e 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -27,12 +27,6 @@ (/show0 "unix.lisp 21") -(defmacro def-enum (inc cur &rest names) - (flet ((defform (name) - (prog1 (when name `(defconstant ,name ,cur)) - (setf cur (funcall inc cur 1))))) - `(progn ,@(mapcar #'defform names)))) - ;;; Given a C-level zero-terminated array of C strings, return a ;;; corresponding Lisp-level list of SIMPLE-STRINGs. (defun c-strings->string-list (c-strings) @@ -48,7 +42,7 @@ ;;;; Lisp types used by syscalls (deftype unix-pathname () 'simple-string) -(deftype unix-fd () `(integer 0 ,most-positive-fixnum)) +(deftype unix-fd () `(integer 0 ,sb!xc:most-positive-fixnum)) (deftype unix-file-mode () '(unsigned-byte 32)) (deftype unix-pid () '(unsigned-byte 32)) @@ -62,6 +56,10 @@ ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other ;;; macros in this file, are only used in this file, and could be ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN. +;;; +;;; SB-EXECUTABLE, at least, uses one of these macros; other libraries +;;; and programs have been known to use them as well. Perhaps they +;;; should live in SB-SYS or even SB-EXT? (defmacro syscall ((name &rest arg-types) success-form &rest args) `(locally @@ -84,11 +82,6 @@ (error "Syscall ~A failed: ~A" ,name (strerror)) ,success-form)))) -(/show0 "unix.lisp 109") - -(defmacro void-syscall ((name &rest arg-types) &rest args) - `(syscall (,name ,@arg-types) (values t 0) ,@args)) - (defmacro int-syscall ((name &rest arg-types) &rest args) `(syscall (,name ,@arg-types) (values result 0) ,@args)) @@ -105,6 +98,9 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (return (values ,value ,errno)))) ,@body)) +(defmacro void-syscall ((name &rest arg-types) &rest args) + `(syscall (,name ,@arg-types) (values t 0) ,@args)) + #!+win32 (progn (defconstant espipe 29)) @@ -206,7 +202,7 @@ corresponds to NAME, or NIL if there is none." ;; 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) +#!-(or win32 openbsd netbsd) (define-alien-type nil (struct timeval (tv-sec time-t) ; seconds @@ -215,7 +211,7 @@ corresponds to NAME, or NIL if there is none." ;; 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. -#!+openbsd +#!+(or openbsd netbsd) (define-alien-type nil (struct timeval (tv-sec long) ; seconds @@ -781,7 +777,7 @@ corresponds to NAME, or NIL if there is none." ;; the POSIX.4 structure for a time value. This is like a "struct ;; timeval" but has nanoseconds instead of microseconds. -#!-openbsd +#!-(or openbsd netbsd) (define-alien-type nil (struct timespec (tv-sec long) ; seconds @@ -790,7 +786,7 @@ corresponds to NAME, or NIL if there is none." ;; 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. -#!+openbsd +#!+(or openbsd netbsd) (define-alien-type nil (struct timespec (tv-sec time-t) ; seconds @@ -812,7 +808,7 @@ corresponds to NAME, or NIL if there is none." (tm-zone c-string))) ; Timezone abbreviation. (define-alien-routine get-timezone sb!alien:void - (when sb!alien:long :in) + (when time-t :in) (seconds-west sb!alien:int :out) (daylight-savings-p sb!alien:boolean :out)) @@ -842,39 +838,6 @@ corresponds to NAME, or NIL if there is none." (struct timezone (tz-minuteswest int) ; minutes west of Greenwich (tz-dsttime int))) ; type of dst correction - -;;; If it works, UNIX-GETTIMEOFDAY returns 5 values: T, the seconds -;;; and microseconds of the current time of day, the timezone (in -;;; minutes west of Greenwich), and a daylight-savings flag. If it -;;; doesn't work, it returns NIL and the errno. -#!-sb-fluid (declaim (inline unix-gettimeofday)) -(defun unix-gettimeofday () - #!+(and x86-64 darwin) - (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. I can't - ;; find any instances in the SBCL where we actually ues the - ;; timezone values, so we just punt for the moment. - (syscall* ("gettimeofday" (* (struct timeval)) - (* (struct timezone))) - (values t - (slot tv 'tv-sec) - (slot tv 'tv-usec)) - (addr tv) - nil)) - #!-(and x86-64 darwin) - (with-alien ((tv (struct timeval)) - (tz (struct timezone))) - (syscall* ("gettimeofday" (* (struct timeval)) - (* (struct timezone))) - (values t - (slot tv 'tv-sec) - (slot tv 'tv-usec) - (slot tz 'tz-minuteswest) - (slot tz 'tz-dsttime)) - (addr tv) - (addr tz)))) ;; Type of the second argument to `getitimer' and @@ -953,24 +916,6 @@ corresponds to NAME, or NIL if there is none." ;;; enough of them all in one place here that they should probably be ;;; removed by hand. -;;;; support routines for dealing with Unix pathnames - -(defun unix-file-kind (name &optional check-for-links) - #!+sb-doc - "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL." - (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) - (ignore dev ino)) - (when res - (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)))))) - (defconstant micro-seconds-per-internal-time-unit (/ 1000000 sb!xc:internal-time-units-per-second)) @@ -978,12 +923,40 @@ corresponds to NAME, or NIL if there is none." ;;; Windows build. #!-win32 (progn + + #!-sb-fluid (declaim (inline get-time-of-day)) + (defun get-time-of-day () + "Return the number of seconds and microseconds since the beginning of +the UNIX epoch (January 1st 1970.)" + #!+darwin + (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)) + (* (struct timezone))) + (values (slot tv 'tv-sec) + (slot tv 'tv-usec)) + (addr tv) + nil)) + #!-(and x86-64 darwin) + (with-alien ((tv (struct timeval)) + (tz (struct timezone))) + (syscall* ("gettimeofday" (* (struct timeval)) + (* (struct timezone))) + (values (slot tv 'tv-sec) + (slot tv 'tv-usec)) + (addr tv) + (addr tz)))) + (declaim (inline system-internal-run-time system-real-time-values)) (defun system-real-time-values () - (multiple-value-bind (_ sec usec) (unix-gettimeofday) - (declare (ignore _) (type (unsigned-byte 32) sec usec)) + (multiple-value-bind (sec usec) (get-time-of-day) + (declare (type (unsigned-byte 32) sec usec)) (values sec (truncate usec micro-seconds-per-internal-time-unit)))) ;; There are two optimizations here that actually matter (on 32-bit @@ -1058,6 +1031,60 @@ corresponds to NAME, or NIL if there is none." micro-seconds-per-internal-time-unit)))) result)))) +;;; FIXME, KLUDGE: GET-TIME-OF-DAY used to be UNIX-GETTIMEOFDAY, and had a +;;; primary return value indicating sucess, and also returned timezone +;;; information -- though the timezone data was not there on Darwin. +;;; Now we have GET-TIME-OF-DAY, but it turns out that despite SB-UNIX being +;;; an implementation package UNIX-GETTIMEOFDAY has users in the wild. +;;; So we're stuck with it for a while -- maybe delete it towards the end +;;; of 2009. +(defun unix-gettimeofday () + (multiple-value-bind (sec usec) (get-time-of-day) + (values t sec usec nil nil))) + +;;;; opendir, readdir, closedir, and dirent-name + +(declaim (inline unix-opendir)) +(defun unix-opendir (namestring &optional (errorp t)) + (let ((dir (alien-funcall + (extern-alien "sb_opendir" + (function system-area-pointer c-string)) + namestring))) + (if (zerop (sap-int dir)) + (when errorp (simple-perror + (format nil "Error opening directory ~S" + namestring))) + dir))) + +(declaim (inline unix-readdir)) +(defun unix-readdir (dir &optional (errorp t) namestring) + (let ((ent (alien-funcall + (extern-alien "sb_readdir" + (function system-area-pointer system-area-pointer)) + dir))) + (if (zerop (sap-int ent)) + (when errorp (simple-perror + (format nil "Error reading directory entry~@[ from ~S~]" + namestring))) + ent))) + +(declaim (inline unix-closedir)) +(defun unix-closedir (dir &optional (errorp t) namestring) + (let ((r (alien-funcall + (extern-alien "sb_closedir" (function int system-area-pointer)) + dir))) + (if (minusp r) + (when errorp (simple-perror + (format nil "Error closing directory~@[ ~S~]" + namestring))) + r))) + +(declaim (inline unix-dirent-name)) +(defun unix-dirent-name (ent) + (alien-funcall + (extern-alien "sb_dirent_name" (function c-string system-area-pointer)) + ent)) + ;;;; A magic constant for wait3(). ;;;; ;;;; FIXME: This used to be defined in run-program.lisp as @@ -1075,8 +1102,7 @@ corresponds to NAME, or NIL if there is none." ;;; not checked for linux... (defmacro fd-set (offset fd-set) - (let ((word (gensym)) - (bit (gensym))) + (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) @@ -1086,8 +1112,7 @@ corresponds to NAME, or NIL if there is none." ;;; not checked for linux... (defmacro fd-clr (offset fd-set) - (let ((word (gensym)) - (bit (gensym))) + (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) @@ -1098,8 +1123,7 @@ corresponds to NAME, or NIL if there is none." ;;; not checked for linux... (defmacro fd-isset (offset fd-set) - (let ((word (gensym)) - (bit (gensym))) + (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)))))