X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=2f1888fa57f0de126c02ec59a4599dd28baffaf1;hb=f369c736b57608402903ce5c59be78a87ef23364;hp=7c1298d3ec7813c1bd707fbd93e448c90a2fbc25;hpb=3c5609fe910bae51ff885c8cfd4be879151e7489;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 7c1298d..2f1888f 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -123,7 +123,8 @@ (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") @@ -489,25 +490,30 @@ `(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) @@ -652,6 +658,18 @@ (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)) @@ -676,7 +694,7 @@ (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) @@ -692,11 +710,11 @@ (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, @@ -706,12 +724,12 @@ (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) @@ -734,9 +752,9 @@ (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 @@ -744,7 +762,7 @@ (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) @@ -811,12 +829,18 @@ previous timer after the body has finished executing" ;;; 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 @@ -837,7 +861,7 @@ previous timer after the body has finished executing" :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) @@ -853,9 +877,9 @@ previous timer after the body has finished executing" (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)) @@ -929,7 +953,8 @@ previous timer after the body has finished executing" (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) @@ -956,34 +981,37 @@ previous timer after the body has finished executing" (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))))