(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
`(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)
(seconds-west sb!alien:int :out)
(daylight-savings-p sb!alien:boolean :out))
+(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))
(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)
- ;; 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))))))))
+ (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))))
projects / sbcl.git / blobdiff