(/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)
;;;; 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))
;;; 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
(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))
(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)
- ;; 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))
+ (defconstant espipe 29))
\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."
+corresponds to NAME, or NIL if there is none."
(name c-string))
\f
;;; from stdio.h
(declare (type unix-fd fd))
(void-syscall ("close" int) fd))
\f
+;;;; stdlib.h
+
+;;; There are good reasons to implement some OPEN options with an
+;;; mkstemp(3)-like routine, but we don't do that yet. Instead, this
+;;; function is used only to make a temporary file for RUN-PROGRAM.
+;;; sb_mkstemp() is a wrapper that lives in src/runtime/wrap.c. Since
+;;; SUSv3 mkstemp() doesn't specify the mode of the created file and
+;;; since we have to implement most of this ourselves for Windows
+;;; anyway, it seems worthwhile to depart from the mkstemp()
+;;; specification by taking a mode to use when creating the new file.
+(defun sb-mkstemp (template-string mode)
+ (declare (type string template-string)
+ (type unix-file-mode mode))
+ (let ((template-buffer (string-to-octets template-string :null-terminate t)))
+ (with-pinned-objects (template-buffer)
+ (let ((fd (alien-funcall (extern-alien "sb_mkstemp"
+ (function int (* char) int))
+ (vector-sap template-buffer)
+ mode)))
+ (if (minusp fd)
+ (values nil (get-errno))
+ (values fd (octets-to-string template-buffer)))))))
+\f
;;;; timebits.h
;; 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
+#!-(or win32 openbsd netbsd)
(define-alien-type nil
(struct timeval
(tv-sec time-t) ; seconds
(tv-usec suseconds-t))) ; and microseconds
+;; 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.
+#!+(or openbsd netbsd)
+(define-alien-type nil
+ (struct timeval
+ (tv-sec long) ; seconds
+ (tv-usec long))) ; and microseconds
+
#!+win32
(define-alien-type nil
(struct timeval
#!+largefile "lseek_largefile"
(function off-t int off-t int))
fd offset whence)))
- (if (minusp result )
+ (if (minusp result)
(values nil (get-errno))
(values result 0))))
;;; It attempts to read len bytes from the device associated with fd
;;; and store them into the buffer. It returns the actual number of
;;; bytes read.
+
+#!-sb!fluid
+(declaim (maybe-inline unix-read))
+
(defun unix-read (fd buf len)
(declare (type unix-fd fd)
(type (unsigned-byte 32) len))
;; 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 linux openbsd freebsd netbsd sunos osf1 darwin hpux win32) (,stub,)
+ #!+(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32)
(or (newcharstar-string (alien-funcall (extern-alien "getcwd"
(function (* char)
(* char)
size-t))
nil
#!+(or linux openbsd freebsd netbsd darwin win32) 0
- #!+(or sunos osf1) 1025))
+ #!+(or sunos osf1 hpux) 1025))
(simple-perror "getcwd")))
;;; Return the Unix current directory as a SIMPLE-STRING terminated
(declare (ignore path))
nil)
+(defun unix-realpath (path)
+ (declare (type unix-pathname path))
+ (with-alien ((ptr (* char)
+ (alien-funcall (extern-alien
+ "sb_realpath"
+ (function (* char) c-string))
+ path)))
+ (if (null-alien ptr)
+ (values nil (get-errno))
+ (multiple-value-prog1
+ (values (with-alien ((c-string c-string ptr)) c-string)
+ nil)
+ (free-alien ptr)))))
+
;;; UNIX-UNLINK accepts a name and deletes the directory entry for that
;;; name and the file if this is the last link.
(defun unix-unlink (name)
;;; st_size is a long, not an off-t, because off-t is a 64-bit
;;; quantity on Alpha. And FIXME: "No one would want a file length
;;; longer than 32 bits anyway, right?":-|
+;;;
+;;; The comment about alien and 64-bit quantities has not been kept in
+;;; sync with the comment now in wrap.h (formerly wrap.c), but it's
+;;; not clear whether either comment is correct. -- RMK 2007-11-14.
(define-alien-type nil
(struct wrapped_stat
- (st-dev #!-(or mips largefile) unsigned-int
- #!+mips unsigned-long
- #!+largefile #!-mips dev-t)
+ (st-dev wst-dev-t)
(st-ino ino-t)
(st-mode mode-t)
- (st-nlink nlink-t)
- (st-uid uid-t)
- (st-gid gid-t)
- (st-rdev #!-(or mips largefile) unsigned-int
- #!+mips unsigned-long
- #!+largefile #!-mips dev-t)
- (st-size #!-(or darwin mips largefile) unsigned-int
- #!+(or darwin mips largefile) off-t)
- #!+(and darwin)
- (st-blksize unsigned-int)
- #!-(and darwin)
- (st-blksize unsigned-long)
- (st-blocks unsigned-long)
+ (st-nlink wst-nlink-t)
+ (st-uid wst-uid-t)
+ (st-gid wst-gid-t)
+ (st-rdev wst-dev-t)
+ (st-size wst-off-t)
+ (st-blksize wst-blksize-t)
+ (st-blocks wst-blkcnt-t)
(st-atime time-t)
(st-mtime time-t)
(st-ctime time-t)))
;; the POSIX.4 structure for a time value. This is like a "struct
;; timeval" but has nanoseconds instead of microseconds.
+#!-(or openbsd netbsd)
(define-alien-type nil
(struct timespec
(tv-sec long) ; seconds
(tv-nsec long))) ; nanoseconds
+;; 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.
+#!+(or openbsd netbsd)
+(define-alien-type nil
+ (struct timespec
+ (tv-sec time-t) ; seconds
+ (tv-nsec long))) ; nanoseconds
+
;; used by other time functions
(define-alien-type nil
(struct tm
(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))))))
-
-;;; Is the Unix pathname PATHNAME relative, instead of absolute? (E.g.
-;;; "passwd" or "etc/passwd" instead of "/etc/passwd"?)
-(defun relative-unix-pathname? (pathname)
- (declare (type simple-string pathname))
- (or (zerop (length pathname))
- (char/= (schar pathname 0) #\/)))
-
-;;; Return PATHNAME with all symbolic links resolved. PATHNAME should
-;;; already be a complete absolute Unix pathname, since at least in
-;;; sbcl-0.6.12.36 we're called only from TRUENAME, and only after
-;;; 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-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 (> 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
- (/noshow pathname previous-pathnames)
- (let ((link (unix-readlink pathname)))
- (/noshow link)
- ;; Unlike the old CMU CL code, we handle a broken symlink by
- ;; returning the link itself. That way, CL:TRUENAME on a
- ;; broken link returns the link itself, so that CL:DIRECTORY
- ;; can return broken links, so that even without
- ;; Unix-specific extensions to do interesting things with
- ;; them, at least Lisp programs can see them and, if
- ;; necessary, delete them. (This is handy e.g. when your
- ;; managed-by-Lisp directories are visited by Emacs, which
- ;; creates broken links as notes to itself.)
- (if (null link)
- (return pathname)
- (let ((new-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 'string dir link))
- link))))
- (if (unix-file-kind new-pathname)
- (setf pathname new-pathname)
- (return pathname)))))
- ;; To generalize the principle that even if portable Lisp code
- ;; can't do anything interesting with a broken symlink, at
- ;; least it should be able to see and delete it, when we
- ;; detect a cyclic link, we return the link itself. (So even
- ;; though portable Lisp code can't do anything interesting
- ;; with a cyclic link, at least it can see it and delete it.)
- (if (member pathname previous-pathnames :test #'string=)
- (return pathname)
- (push pathname previous-pathnames))))
-\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
(setf (values e-sec e-msec) (system-real-time-values)
c-sec 0
c-msec 0))
- ;; If two threads call this at the same time, we're still safe, I believe,
- ;; as long as NOW is updated before either of C-MSEC or C-SEC. Same applies
- ;; to interrupts. --NS
+ ;; If two threads call this at the same time, we're still safe, I
+ ;; believe, as long as NOW is updated before either of C-MSEC or
+ ;; C-SEC. Same applies to interrupts. --NS
+ ;;
+ ;; I believe this is almost correct with x86/x86-64 cache
+ ;; coherency, but if the new value of C-SEC, C-MSEC can become
+ ;; visible to another CPU without NOW doing the same then it's
+ ;; unsafe. It's `almost' correct on x86 because writes by other
+ ;; processors may become visible in any order provided transitity
+ ;; holds. With at least three cpus, C-MSEC and C-SEC may be from
+ ;; different threads and an incorrect value may be returned.
+ ;; Considering that this failure is not detectable by the caller -
+ ;; it looks like time passes a bit slowly - and that it should be
+ ;; an extremely rare occurance I'm inclinded to leave it as it is.
+ ;; --MG
(defun get-internal-real-time ()
(multiple-value-bind (sec msec) (system-real-time-values)
(unless (and (= msec c-msec) (= sec c-sec))
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
;;; 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)
;;; 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)
;;; 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)))))