\f
;;;; Lisp types used by syscalls
-(deftype unix-pathname () 'simple-base-string)
+(deftype unix-pathname () 'simple-string)
(deftype unix-fd () `(integer 0 ,most-positive-fixnum))
(deftype unix-file-mode () '(unsigned-byte 32))
#!+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)
\f
;;;; hacking the Unix environment
+#!-win32
(define-alien-routine ("getenv" posix-getenv) c-string
"Return the \"value\" part of the environment string \"name=value\" which
corresponds to NAME, or NIL if there is none."
;;; Rename the file with string NAME1 to the string NAME2. NIL and an
;;; error code is returned if an error occurs.
+#!-win32
(defun unix-rename (name1 name2)
(declare (type unix-pathname name1 name2))
(void-syscall ("rename" c-string c-string) name1 name2))
;;; w_ok Write permission.
;;; x_ok Execute permission.
;;; f_ok Presence of file.
-#!-win32
+
+;;; In Windows, the MODE argument to access is defined in terms of
+;;; literal magic numbers---there are no constants to grovel. X_OK
+;;; is not defined.
+#!+win32
+(progn
+ (defconstant f_ok 0)
+ (defconstant w_ok 2)
+ (defconstant r_ok 4))
+
(defun unix-access (path mode)
(declare (type unix-pathname path)
(type (mod 8) mode))
(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 ()
+ (with-alien ((fds (array int 2)))
+ (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
;; would put five and twenty-seven together and ask us about it, so...
;; -- AB, 2005-12-27
+#!-win32
(defun unix-mkdir (name mode)
(declare (type unix-pathname name)
(type unix-file-mode mode)
;;; Return the Unix current directory as a SIMPLE-STRING, in the
;;; style returned by getcwd() (no trailing slash character).
+#!-win32
(defun posix-getcwd ()
;; This implementation relies on a BSD/Linux extension to getcwd()
;; behavior, automatically allocating memory when a null buffer
(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)
;;; 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...)
;; KLUDGE: readlink and lstat are unreliable if given symlinks
;; ending in slashes -- fix the issue here instead of waiting for
;; libc to change...
+ ;;
+ ;; but be careful! Must not strip the final slash from "/". (This
+ ;; adjustment might be a candidate for being transferred into the C
+ ;; code in a wrap_readlink() function, too.) CSR, 2006-01-18
(let ((len (length pathname)))
- (when (and (plusp len) (eql #\/ (schar pathname (1- len))))
+ (when (and (> len 1) (eql #\/ (schar pathname (1- len))))
(setf pathname (subseq pathname 0 (1- len)))))
(/noshow "entering UNIX-RESOLVE-LINKS")
(loop with previous-pathnames = nil do
: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)
(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))
(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)))))
+
+\f
+;;; 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))))
\f
;;;; A magic constant for wait3().
;;;;
`(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))))
+
projects / sbcl.git / blobdiff