;;; 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?
-(eval-when (:compile-toplevel :execute)
-(sb!xc:defmacro syscall ((name &rest arg-types) success-form &rest args)
+(defmacro syscall ((name &rest arg-types) success-form &rest args)
`(locally
(declare (optimize (sb!c::float-accuracy 0)))
(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
;;; This is like SYSCALL, but if it fails, signal an error instead of
;;; returning error codes. Should only be used for syscalls that will
;;; never really get an error.
-(sb!xc:defmacro syscall* ((name &rest arg-types) success-form &rest args)
+(defmacro syscall* ((name &rest arg-types) success-form &rest args)
`(locally
(declare (optimize (sb!c::float-accuracy 0)))
(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
(error "Syscall ~A failed: ~A" ,name (strerror))
,success-form))))
-(sb!xc:defmacro int-syscall ((name &rest arg-types) &rest args)
+(defmacro int-syscall ((name &rest arg-types) &rest args)
`(syscall (,name ,@arg-types) (values result 0) ,@args))
-(sb!xc:defmacro with-restarted-syscall ((&optional (value (gensym))
+(defmacro with-restarted-syscall ((&optional (value (gensym))
(errno (gensym)))
syscall-form &rest body)
#!+sb-doc
(unless #!-win32 (eql ,errno sb!unix:eintr) #!+win32 nil
(return (values ,value ,errno))))
,@body))
-) ; EVAL-WHEN
-;;; FIXME: This could go in the above EVAL-WHEN, but it's used by
-;;; SB-EXECUTABLE.
(defmacro void-syscall ((name &rest arg-types) &rest args)
`(syscall (,name ,@arg-types) (values t 0) ,@args))
;; 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
;; 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
;; 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
;; 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
(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))
(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))))
\f
;; Type of the second argument to `getitimer' and
;;; enough of them all in one place here that they should probably be
;;; removed by hand.
\f
-;;;; 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))))))
-\f
(defconstant micro-seconds-per-internal-time-unit
(/ 1000000 sb!xc:internal-time-units-per-second))
;;; 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
micro-seconds-per-internal-time-unit))))
result))))
\f
+;;; 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)))
+\f
+;;;; 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))
+\f
;;;; A magic constant for wait3().
;;;;
;;;; FIXME: This used to be defined in run-program.lisp as
projects / sbcl.git / blobdiff