X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=7da7e555fb39ef778a59c692dff79f84c8f3f93b;hb=4dc4761909992ceb346d003f3fb19e5c837ee985;hp=c1b32ab39c0303c8d8a4076a019447fb21280b8f;hpb=3a618201c9f2370bb8784217a866d000371769e5;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index c1b32ab..7da7e55 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") @@ -241,7 +242,7 @@ ;;; 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) @@ -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,7 +829,7 @@ 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))) (/noshow "entering UNIX-RESOLVE-LINKS") (loop with previous-pathnames = nil do @@ -837,7 +855,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 +871,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 +947,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,32 +975,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) - (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))))