X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=40cfd07b24f9aa14d1e4a9870dfea708a820ced4;hb=2b90fd1dbad23322258222a2ef4cef7f6a00831d;hp=8312381a2dff9a2aae3596225d7947ac9ce8eb69;hpb=c03ebb54770cfa613d4b706a80e5be231786a5d0;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 8312381..40cfd07 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -47,7 +47,7 @@ ;;;; Lisp types used by syscalls -(deftype unix-pathname () #!-win32 'simple-base-string #!+win32 'simple-string) +(deftype unix-pathname () 'simple-string) (deftype unix-fd () `(integer 0 ,most-positive-fixnum)) (deftype unix-file-mode () '(unsigned-byte 32)) @@ -107,26 +107,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!+win32 (progn - (defconstant o_rdonly 0) - (defconstant o_wronly 1) - (defconstant o_rdwr 2) - (defconstant o_creat #x100) - (defconstant o_trunc #x200) - (defconstant o_append #x008) - (defconstant o_excl #x400) - (defconstant enoent 2) - (defconstant eexist 17) (defconstant espipe 29) - (defconstant o_binary #x8000) - (defconstant s-ifmt #xf000) - (defconstant s-ifdir #x4000) - (defconstant s-ifreg #x8000) - (define-alien-type ino-t short) - (define-alien-type time-t long) - (define-alien-type off-t long) - (define-alien-type size-t long) - (define-alien-type mode-t unsigned-short) - ;; For stat-wrapper hack (different-type or non-existing win32 fields). (define-alien-type nlink-t short) (define-alien-type uid-t short) @@ -314,18 +295,21 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; value is the pipe to be read from and the second is can be written ;;; to. If an error occurred the first value is NIL and the second the ;;; unix error code. -#!-win32(defun unix-pipe () +#!-win32 +(defun unix-pipe () (with-alien ((fds (array int 2))) (syscall ("pipe" (* int)) (values (deref fds 0) (deref fds 1)) (cast fds (* int))))) -#!+win32(defun msvcrt-raw-pipe (fds size mode) - (syscall ("_pipe" (* int) int int) - (values (deref fds 0) (deref fds 1)) - (cast fds (* int)) size mode)) -#!+win32(defun unix-pipe () +#!+win32 +(defun msvcrt-raw-pipe (fds size mode) + (syscall ("_pipe" (* int) int int) + (values (deref fds 0) (deref fds 1)) + (cast fds (* int)) size mode)) +#!+win32 +(defun unix-pipe () (with-alien ((fds (array int 2))) - (msvcrt-raw-pipe fds 256 o_binary))) + (msvcrt-raw-pipe fds 256 o_binary))) ;; Windows mkdir() doesn't take the mode argument. It's cdecl, so we could ;; actually call it passing the mode argument, but some sharp-eyed reader @@ -864,7 +848,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun unix-file-kind (name &optional check-for-links) #!+sb-doc "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL." - (declare (simple-base-string name)) + (declare (simple-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) @@ -890,7 +874,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; 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-base-string pathname)) + (declare (type simple-string pathname)) ;; KLUDGE: The Win32 platform doesn't have symbolic links, so ;; short-cut this computation (and the check for being an absolute ;; unix pathname...) @@ -930,7 +914,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." :from-end t))) (dir (subseq pathname 0 dir-len))) (/noshow dir) - (concatenate 'base-string dir link)) + (concatenate 'string dir link)) link)))) (if (unix-file-kind new-pathname) (setf pathname new-pathname) @@ -946,9 +930,9 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (push pathname previous-pathnames)))) (defun unix-simplify-pathname (src) - (declare (type simple-base-string src)) + (declare (type simple-string src)) (let* ((src-len (length src)) - (dst (make-string src-len :element-type 'base-char)) + (dst (make-string src-len :element-type 'character)) (dst-len 0) (dots 0) (last-slash nil)) @@ -1023,13 +1007,49 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (if prev-prev-slash (setf dst-len (1+ prev-prev-slash)) (return-from unix-simplify-pathname - (coerce "./" 'simple-base-string)))))))) + (coerce "./" 'simple-string)))))))) (cond ((zerop dst-len) "./") ((= dst-len src-len) dst) (t (subseq dst 0 dst-len))))) + + +;;; UNIX specific code, that has been cleanly separated from the +;;; Windows build. +#!-win32 +(progn + (defconstant micro-seconds-per-internal-time-unit + (/ 1000000 sb!xc:internal-time-units-per-second)) + + (declaim (inline system-internal-real-time system-internal-run-time)) + (defun system-internal-real-time () + (multiple-value-bind (ignore seconds useconds) (unix-gettimeofday) + (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds)) + (let ((uint (truncate useconds + micro-seconds-per-internal-time-unit))) + (declare (type (unsigned-byte 32) uint)) + (+ (* seconds sb!xc:internal-time-units-per-second) + uint)))) + + (defun system-internal-run-time () + (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec) + (unix-fast-getrusage rusage_self) + (declare (ignore ignore) + (type (unsigned-byte 31) utime-sec stime-sec) + ;; (Classic CMU CL had these (MOD 1000000) instead, but + ;; at least in Linux 2.2.12, the type doesn't seem to + ;; be documented anywhere and the observed behavior is + ;; to sometimes return 1000000 exactly.) + (type (integer 0 1000000) utime-usec stime-usec)) + (let ((result (+ (* (+ utime-sec stime-sec) + sb!xc:internal-time-units-per-second) + (floor (+ utime-usec + stime-usec + (floor micro-seconds-per-internal-time-unit 2)) + micro-seconds-per-internal-time-unit)))) + result)))) ;;;; A magic constant for wait3(). ;;;; @@ -1082,3 +1102,4 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." `(progn ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits) collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) +