\f
;;;; Lisp types used by syscalls
-(deftype unix-pathname () 'simple-string)
+(deftype unix-pathname () 'simple-base-string)
(deftype unix-fd () `(integer 0 ,most-positive-fixnum))
(deftype unix-file-mode () '(unsigned-byte 32))
;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
(defmacro syscall ((name &rest arg-types) success-form &rest args)
- `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
+ `(locally
+ (declare (optimize (sb!c::float-accuracy 0)))
+ (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
,@args)))
- (if (minusp result)
- (values nil (get-errno))
- ,success-form)))
+ (if (minusp result)
+ (values nil (get-errno))
+ ,success-form))))
;;; 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.
(defmacro syscall* ((name &rest arg-types) success-form &rest args)
- `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
- ,@args)))
- (if (minusp result)
- (error "Syscall ~A failed: ~A" ,name (strerror))
- ,success-form)))
+ `(locally
+ (declare (optimize (sb!c::float-accuracy 0)))
+ (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
+ ,@args)))
+ (if (minusp result)
+ (error "Syscall ~A failed: ~A" ,name (strerror))
+ ,success-form))))
(/show0 "unix.lisp 109")
(defconstant l_incr 1) ; to increment the file pointer
(defconstant l_xtnd 2) ; to extend the file size
-;;; Accept a file descriptor and move the file pointer ahead
-;;; a certain offset for that file. WHENCE can be any of the following:
-;;; L_SET Set the file pointer.
-;;; L_INCR Increment the file pointer.
-;;; L_XTND Extend the file size.
+;;; Is a stream interactive?
+(defun unix-isatty (fd)
+ (declare (type unix-fd fd))
+ (int-syscall ("isatty" int) fd))
+
(defun unix-lseek (fd offset whence)
+ "Unix-lseek accepts a file descriptor and moves the file pointer by
+ OFFSET octets. Whence can be any of the following:
+
+ L_SET Set the file pointer.
+ L_INCR Increment the file pointer.
+ L_XTND Extend the file size.
+ "
(declare (type unix-fd fd)
- (type (unsigned-byte 32) offset)
(type (integer 0 2) whence))
- #!-(and x86 bsd)
- (int-syscall ("lseek" int off-t int) fd offset whence)
- ;; Need a 64-bit return value type for this. TBD. For now,
- ;; don't use this with any 2G+ partitions.
- #!+(and x86 bsd)
- (int-syscall ("lseek" int unsigned-long unsigned-long int)
- fd offset 0 whence))
+ (let ((result (alien-funcall (extern-alien "lseek" (function off-t int off-t int))
+ fd offset whence)))
+ (if (minusp result )
+ (values nil (get-errno))
+ (values result 0))))
;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read.
;;; It attempts to read len bytes from the device associated with fd
;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the
;;; length to write. It attempts to write len bytes to the device
-;;; associated with fd from the the buffer starting at offset. It returns
+;;; associated with fd from the buffer starting at offset. It returns
;;; the actual number of bytes written.
(defun unix-write (fd buf offset len)
(declare (type unix-fd fd)
;; 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 sunos osf1) (,stub,)
- #!+(or linux openbsd freebsd sunos osf1)
+ #!-(or linux openbsd freebsd netbsd sunos osf1 darwin) (,stub,)
+ #!+(or linux openbsd freebsd netbsd sunos osf1 darwin)
(or (newcharstar-string (alien-funcall (extern-alien "getcwd"
(function (* char)
(* char)
size-t))
nil
- #!+(or linux openbsd freebsd) 0
+ #!+(or linux openbsd freebsd netbsd darwin) 0
#!+(or sunos osf1) 1025))
(simple-perror "getcwd")))
(cast buf c-string)
(cast buf (* char)) 256)))
-;;; Write the core image of the file described by FD to disk.
-(defun unix-fsync (fd)
- (declare (type unix-fd fd))
- (void-syscall ("fsync" int) fd))
-\f
+(defun unix-setsid ()
+ (int-syscall ("setsid")))
+
;;;; sys/ioctl.h
;;; UNIX-IOCTL performs a variety of operations on open i/o
;;; information.
(defun unix-ioctl (fd cmd arg)
(declare (type unix-fd fd)
- (type (unsigned-byte 32) cmd))
- (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
+ (type (signed-byte 32) cmd))
+ (void-syscall ("ioctl" int int (* char)) fd cmd arg))
\f
;;;; sys/resource.h
;;; longer than 32 bits anyway, right?":-|
(define-alien-type nil
(struct wrapped_stat
- (st-dev unsigned-long) ; would be dev-t in a real stat
+ (st-dev unsigned-int) ; would be dev-t in a real stat
(st-ino ino-t)
(st-mode mode-t)
(st-nlink nlink-t)
(st-uid uid-t)
(st-gid gid-t)
- (st-rdev unsigned-long) ; would be dev-t in a real stat
- (st-size unsigned-long) ; would be off-t in a real stat
+ (st-rdev unsigned-int) ; would be dev-t in a real stat
+ (st-size unsigned-int) ; would be off-t in a real stat
(st-blksize unsigned-long)
(st-blocks unsigned-long)
(st-atime time-t)
(define-alien-routine get-timezone sb!alien:void
(when sb!alien:long :in)
- (minutes-west sb!alien:int :out)
+ (seconds-west sb!alien:int :out)
(daylight-savings-p sb!alien:boolean :out))
-(defun unix-get-minutes-west (secs)
- (multiple-value-bind (ignore minutes dst) (get-timezone secs)
+(defun unix-get-seconds-west (secs)
+ (multiple-value-bind (ignore seconds dst) (get-timezone secs)
(declare (ignore ignore) (ignore dst))
- (values minutes)))
-
-(defun unix-get-timezone (secs)
- (multiple-value-bind (ignore minutes dst) (get-timezone secs)
- (declare (ignore ignore) (ignore minutes))
- (values (deref unix-tzname (if dst 1 0)))))
-
+ (values seconds)))
\f
;;;; sys/time.h
(addr tz))))
\f
-(defconstant ENOENT 2) ; Unix error code, "No such file or directory"
-(defconstant EINTR 4) ; Unix error code, "Interrupted system call"
-(defconstant EIO 5) ; Unix error code, "I/O error"
-(defconstant EEXIST 17) ; Unix error code, "File exists"
-(defconstant ESPIPE 29) ; Unix error code, "Illegal seek"
-(defconstant EWOULDBLOCK 11) ; Unix error code, "Operation would block"
+;; Type of the second argument to `getitimer' and
+;; the second and third arguments `setitimer'.
+(define-alien-type nil
+ (struct itimerval
+ (it-interval (struct timeval)) ; timer interval
+ (it-value (struct timeval)))) ; current value
+
+(defconstant ITIMER-REAL 0)
+(defconstant ITIMER-VIRTUAL 1)
+(defconstant ITIMER-PROF 2)
+
+(defun unix-getitimer(which)
+ "Unix-getitimer returns the INTERVAL and VALUE slots of one of
+ three system timers (:real :virtual or :profile). On success,
+ unix-getitimer returns 5 values,
+ T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec."
+ (declare (type (member :real :virtual :profile) which)
+ (values t
+ (unsigned-byte 29) (mod 1000000)
+ (unsigned-byte 29) (mod 1000000)))
+ (let ((which (ecase which
+ (:real ITIMER-REAL)
+ (:virtual ITIMER-VIRTUAL)
+ (:profile ITIMER-PROF))))
+ (with-alien ((itv (struct itimerval)))
+ (syscall* ("getitimer" int (* (struct itimerval)))
+ (values T
+ (slot (slot itv 'it-interval) 'tv-sec)
+ (slot (slot itv 'it-interval) 'tv-usec)
+ (slot (slot itv 'it-value) 'tv-sec)
+ (slot (slot itv 'it-value) 'tv-usec))
+ which (alien-sap (addr itv))))))
+
+(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
+ will be delivered VALUE <seconds+microseconds> from now. INTERVAL,
+ when non-zero, is <seconds+microseconds> to be loaded each time
+ the timer expires. Setting INTERVAL and VALUE to zero disables
+ the timer. See the Unix man page for more details. On success,
+ unix-setitimer returns the old contents of the INTERVAL and VALUE
+ slots as in unix-getitimer."
+ (declare (type (member :real :virtual :profile) which)
+ (type (unsigned-byte 29) int-secs val-secs)
+ (type (integer 0 (1000000)) int-usec val-usec)
+ (values t
+ (unsigned-byte 29) (mod 1000000)
+ (unsigned-byte 29) (mod 1000000)))
+ (let ((which (ecase which
+ (:real ITIMER-REAL)
+ (:virtual ITIMER-VIRTUAL)
+ (:profile ITIMER-PROF))))
+ (with-alien ((itvn (struct itimerval))
+ (itvo (struct itimerval)))
+ (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs
+ (slot (slot itvn 'it-interval) 'tv-usec) int-usec
+ (slot (slot itvn 'it-value ) 'tv-sec ) val-secs
+ (slot (slot itvn 'it-value ) 'tv-usec) val-usec)
+ (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
+ (values T
+ (slot (slot itvo 'it-interval) 'tv-sec)
+ (slot (slot itvo 'it-interval) 'tv-usec)
+ (slot (slot itvo 'it-value) 'tv-sec)
+ (slot (slot itvo 'it-value) 'tv-usec))
+ which (alien-sap (addr itvn))(alien-sap (addr itvo))))))
+
+(defmacro sb!ext:with-timeout (expires &body body)
+ "Execute the body, interrupting it with a SIGALRM after at least
+EXPIRES seconds have passed. Uses Unix setitimer(), restoring any
+previous timer after the body has finished executing"
+ (with-unique-names (saved-seconds saved-useconds s u)
+ `(let (- ,saved-seconds ,saved-useconds)
+ (multiple-value-setq (- - - ,saved-seconds ,saved-useconds)
+ (unix-getitimer :real))
+ (multiple-value-bind (,s ,u) (floor ,expires)
+ (setf ,u (floor (* ,u 1000000)))
+ (if (and (> ,expires 0)
+ (or (and (zerop ,saved-seconds) (zerop ,saved-useconds))
+ (> ,saved-seconds ,s)
+ (and (= ,saved-seconds ,s)
+ (> ,saved-useconds ,u))))
+ (unwind-protect
+ (progn
+ (unix-setitimer :real 0 0 ,s ,u)
+ ,@body)
+ (unix-setitimer :real 0 0 ,saved-seconds ,saved-useconds))
+ (progn
+ ,@body))))))
+\f
;;; FIXME: Many Unix error code definitions were deleted from the old
;;; CMU CL source code here, but not in the exports of SB-UNIX. I
;;; (WHN) hope that someday I'll figure out an automatic way to detect
;;; enough of them all in one place here that they should probably be
;;; removed by hand.
\f
-\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))
+ (declare (simple-base-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)
;;; 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))
+ (declare (type simple-base-string pathname))
(aver (not (relative-unix-pathname? pathname)))
(/noshow "entering UNIX-RESOLVE-LINKS")
(loop with previous-pathnames = nil do
:from-end t)))
(dir (subseq pathname 0 dir-len)))
(/noshow dir)
- (concatenate 'string dir link))
+ (concatenate 'base-string dir link))
link))))
(if (unix-file-kind new-pathname)
(setf pathname new-pathname)
(push pathname previous-pathnames))))
(defun unix-simplify-pathname (src)
- (declare (type simple-string src))
+ (declare (type simple-base-string src))
(let* ((src-len (length src))
- (dst (make-string src-len))
+ (dst (make-string src-len :element-type 'base-char))
(dst-len 0)
(dots 0)
(last-slash nil))
(position #\/ dst :end last-slash :from-end t)))
(if prev-prev-slash
(setf dst-len (1+ prev-prev-slash))
- (return-from unix-simplify-pathname "./")))))))
+ (return-from unix-simplify-pathname
+ (coerce "./" 'simple-base-string))))))))
(cond ((zerop dst-len)
"./")
((= dst-len src-len)
`(multiple-value-bind (,word ,bit) (floor ,offset 32)
(setf (deref (slot ,fd-set 'fds-bits) ,word)
(logand (deref (slot ,fd-set 'fds-bits) ,word)
- (sb!kernel:32bit-logical-not
+ ;; FIXME: This may not be quite right for 64-bit
+ ;; ports of SBCL. --njf, 2004-08-04
+ (sb!kernel:word-logical-not
(truly-the (unsigned-byte 32) (ash 1 ,bit))))))))
;;; not checked for linux...
projects / sbcl.git / blobdiff