;;; 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")
(define-alien-type nil
(struct fd-set
- (fds-bits (array fd-mask #.(/ fd-setsize 32)))))
+ (fds-bits (array fd-mask #.(/ fd-setsize
+ sb!vm:n-machine-word-bits)))))
(/show0 "unix.lisp 304")
\f
;;; 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 darwin) (,stub,)
- #!+(or linux openbsd freebsd sunos osf1 darwin)
+ #!-(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 darwin) 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")))
`(if (fixnump ,num)
(progn
(setf (deref (slot ,fdset 'fds-bits) 0) ,num)
- ,@(loop for index upfrom 1 below (/ fd-setsize 32)
+ ,@(loop for index upfrom 1 below (/ fd-setsize
+ sb!vm:n-machine-word-bits)
collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
(progn
- ,@(loop for index upfrom 0 below (/ fd-setsize 32)
+ ,@(loop for index upfrom 0 below (/ fd-setsize
+ sb!vm:n-machine-word-bits)
collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
- (ldb (byte 32 ,(* index 32)) ,num))))))
+ (ldb (byte sb!vm:n-machine-word-bits
+ ,(* index sb!vm:n-machine-word-bits))
+ ,num))))))
(defmacro fd-set-to-num (nfds fdset)
- `(if (<= ,nfds 32)
+ `(if (<= ,nfds sb!vm:n-machine-word-bits)
(deref (slot ,fdset 'fds-bits) 0)
- (+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
+ (+ ,@(loop for index upfrom 0 below (/ fd-setsize
+ sb!vm:n-machine-word-bits)
collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
- ,(* index 32))))))
+ ,(* index sb!vm:n-machine-word-bits))))))
;;; Examine the sets of descriptors passed as arguments to see whether
;;; they are ready for reading and writing. See the UNIX Programmer's
;;; Manual for more information.
(defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
- (declare (type (integer 0 #.FD-SETSIZE) nfds)
+ (declare (type (integer 0 #.fd-setsize) nfds)
(type unsigned-byte rdfds wrfds xpfds)
(type (or (unsigned-byte 31) null) to-secs)
(type (unsigned-byte 31) to-usecs)
(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 nanosleep (secs nsecs)
+ (with-alien ((req (struct timespec))
+ (rem (struct timespec)))
+ (setf (slot req 'tv-sec) secs)
+ (setf (slot req 'tv-nsec) nsecs)
+ (loop while (eql sb!unix:eintr
+ (nth-value 1
+ (int-syscall ("nanosleep" (* (struct timespec))
+ (* (struct timespec)))
+ (addr req) (addr rem))))
+ do (rotatef req rem))))
+
+(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
(tz (struct timezone)))
(syscall* ("gettimeofday" (* (struct timeval))
(* (struct timezone)))
- (values T
+ (values t
(slot tv 'tv-sec)
(slot tv 'tv-usec)
(slot tz 'tz-minuteswest)
(it-interval (struct timeval)) ; timer interval
(it-value (struct timeval)))) ; current value
-(defconstant ITIMER-REAL 0)
-(defconstant ITIMER-VIRTUAL 1)
-(defconstant ITIMER-PROF 2)
+(defconstant itimer-real 0)
+(defconstant itimer-virtual 1)
+(defconstant itimer-prof 2)
-(defun unix-getitimer(which)
+(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,
(unsigned-byte 29) (mod 1000000)
(unsigned-byte 29) (mod 1000000)))
(let ((which (ecase which
- (:real ITIMER-REAL)
- (:virtual ITIMER-VIRTUAL)
- (:profile ITIMER-PROF))))
+ (:real itimer-real)
+ (:virtual itimer-virtual)
+ (:profile itimer-prof))))
(with-alien ((itv (struct itimerval)))
(syscall* ("getitimer" int (* (struct itimerval)))
- (values T
+ (values t
(slot (slot itv 'it-interval) 'tv-sec)
(slot (slot itv 'it-interval) 'tv-usec)
(slot (slot itv 'it-value) 'tv-sec)
(unsigned-byte 29) (mod 1000000)
(unsigned-byte 29) (mod 1000000)))
(let ((which (ecase which
- (:real ITIMER-REAL)
- (:virtual ITIMER-VIRTUAL)
- (:profile ITIMER-PROF))))
+ (: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-value ) 'tv-sec ) val-secs
(slot (slot itvn 'it-value ) 'tv-usec) val-usec)
(syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
- (values T
+ (values t
(slot (slot itvo 'it-interval) 'tv-sec)
(slot (slot itvo 'it-interval) 'tv-usec)
(slot (slot itvo 'it-value) 'tv-sec)
;;; 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)))
+ ;; KLUDGE: readlink and lstat are unreliable if given symlinks
+ ;; ending in slashes -- fix the issue here instead of waiting for
+ ;; libc to change...
+ (let ((len (length pathname)))
+ (when (and (plusp len) (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 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
: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)
(defmacro fd-set (offset fd-set)
(let ((word (gensym))
(bit (gensym)))
- `(multiple-value-bind (,word ,bit) (floor ,offset 32)
+ `(multiple-value-bind (,word ,bit) (floor ,offset
+ sb!vm:n-machine-word-bits)
(setf (deref (slot ,fd-set 'fds-bits) ,word)
- (logior (truly-the (unsigned-byte 32) (ash 1 ,bit))
+ (logior (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
+ (ash 1 ,bit))
(deref (slot ,fd-set 'fds-bits) ,word))))))
;;; not checked for linux...
(defmacro fd-clr (offset fd-set)
(let ((word (gensym))
(bit (gensym)))
- `(multiple-value-bind (,word ,bit) (floor ,offset 32)
+ `(multiple-value-bind (,word ,bit) (floor ,offset
+ sb!vm:n-machine-word-bits)
(setf (deref (slot ,fd-set 'fds-bits) ,word)
(logand (deref (slot ,fd-set 'fds-bits) ,word)
- (sb!kernel:32bit-logical-not
- (truly-the (unsigned-byte 32) (ash 1 ,bit))))))))
+ (sb!kernel:word-logical-not
+ (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
+ (ash 1 ,bit))))))))
;;; not checked for linux...
(defmacro fd-isset (offset fd-set)
(let ((word (gensym))
(bit (gensym)))
- `(multiple-value-bind (,word ,bit) (floor ,offset 32)
+ `(multiple-value-bind (,word ,bit) (floor ,offset
+ sb!vm:n-machine-word-bits)
(logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
;;; not checked for linux...
(defmacro fd-zero (fd-set)
`(progn
- ,@(loop for index upfrom 0 below (/ fd-setsize 32)
+ ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits)
collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))