X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=7a1a62888c6d29f34fd0457e39aebf85328226de;hb=a6a12ed609d5467ec43b411283e5b3568fee81df;hp=ae5875f2a2743875f721cb274f884d983eb63fa9;hpb=800666c9dd66dd953c648b98fdcb340d68510175;p=sbcl.git

diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index ae5875f..7a1a628 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -111,7 +111,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
 (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."
-  (name c-string))
+  (name (c-string :not-null t)))
 
 ;;; from stdio.h
 
@@ -120,7 +120,9 @@ corresponds to NAME, or NIL if there is none."
 #!-win32
 (defun unix-rename (name1 name2)
   (declare (type unix-pathname name1 name2))
-  (void-syscall ("rename" c-string c-string) name1 name2))
+  (void-syscall ("rename" (c-string :not-null t)
+                          (c-string :not-null t))
+                name1 name2))
 
 ;;; from sys/types.h and gnu/types.h
 
@@ -274,6 +276,7 @@ corresponds to NAME, or NIL if there is none."
   (void-syscall ("access" c-string int) path mode))
 
 ;;; values for the second argument to UNIX-LSEEK
+;;; Note that nowadays these are called SEEK_SET, SEEK_CUR, and SEEK_END
 (defconstant l_set 0) ; to set the file pointer
 (defconstant l_incr 1) ; to increment the file pointer
 (defconstant l_xtnd 2) ; to extend the file size
@@ -424,9 +427,20 @@ corresponds to NAME, or NIL if there is none."
 ;;; Terminate the current process with an optional error code. If
 ;;; successful, the call doesn't return. If unsuccessful, the call
 ;;; returns NIL and an error number.
-(defun unix-exit (&optional (code 0))
-  (declare (type (signed-byte 32) code))
-  (void-syscall ("exit" int) code))
+(deftype exit-code ()
+  `(signed-byte 32))
+(defun os-exit (code &key abort)
+  #!+sb-doc
+  "Exit the process with CODE. If ABORT is true, exit is performed using _exit(2),
+avoiding atexit(3) hooks, etc. Otherwise exit(2) is called."
+  (unless (typep code 'exit-code)
+    (setf code (if abort 1 0)))
+  (if abort
+      (void-syscall ("_exit" int) code)
+      (void-syscall ("exit" int) code)))
+
+(define-deprecated-function :early "1.0.56.55" unix-exit os-exit (code)
+  (os-exit code))
 
 ;;; Return the process id of the current process.
 (define-alien-routine ("getpid" unix-getpid) int)
@@ -446,11 +460,18 @@ corresponds to NAME, or NIL if there is none."
 ;;; Return the namestring of the home directory, being careful to
 ;;; include a trailing #\/
 #!-win32
-(defun uid-homedir (uid)
-  (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir"
-                                                       (function (* char) int))
-                                         uid))
-      (error "failed to resolve home directory for Unix uid=~S" uid)))
+(progn
+  (defun uid-homedir (uid)
+    (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir"
+                                                         (function (* char) int))
+                                           uid))
+        (error "failed to resolve home directory for Unix uid=~S" uid)))
+
+  (defun user-homedir (uid)
+    (or (newcharstar-string (alien-funcall (extern-alien "user_homedir"
+                                                         (function (* char) c-string))
+                                           uid))
+        (error "failed to resolve home directory for Unix uid=~S" uid))))
 
 ;;; Invoke readlink(2) on the file name specified by PATH. Return
 ;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on
@@ -871,6 +892,31 @@ corresponds to NAME, or NIL if there is none."
     (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
              (%extract-stat-results (addr buf))
              fd (addr buf))))
+
+#!-win32
+(defun fd-type (fd)
+  (declare (type unix-fd fd))
+  (let ((fmt (logand
+              sb!unix:s-ifmt
+              (or (with-alien ((buf (struct wrapped_stat)))
+                    (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
+                             (slot buf 'st-mode)
+                             fd (addr buf)))
+                  0))))
+    (cond ((logtest sb!unix:s-ififo fmt)
+           :fifo)
+          ((logtest sb!unix:s-ifchr fmt)
+           :character)
+          ((logtest sb!unix:s-ifdir fmt)
+           :directory)
+          ((logtest sb!unix:s-ifblk fmt)
+           :block)
+          ((logtest sb!unix:s-ifreg fmt)
+           :regular)
+          ((logtest sb!unix:s-ifsock fmt)
+           :socket)
+          (t
+           :unknown))))
 
 ;;;; time.h
 
@@ -915,8 +961,8 @@ corresponds to NAME, or NIL if there is none."
 (defun nanosleep (secs nsecs)
   (with-alien ((req (struct timespec))
                (rem (struct timespec)))
-    (setf (slot req 'tv-sec) secs)
-    (setf (slot req 'tv-nsec) nsecs)
+    (setf (slot req 'tv-sec) secs
+          (slot req 'tv-nsec) nsecs)
     (loop while (and (eql sb!unix:eintr
                           (nth-value 1
                                      (int-syscall ("nanosleep" (* (struct timespec))
@@ -941,10 +987,12 @@ corresponds to NAME, or NIL if there is none."
                            (rem-nsec (slot rem 'tv-nsec)))
                        (when (or (> secs rem-sec)
                                  (and (= secs rem-sec) (>= nsecs rem-nsec)))
-                         (setf secs rem-sec
+                         ;; Update for next round.
+                         (setf secs  rem-sec
                                nsecs rem-nsec)
                          t)))
-          do (rotatef req rem))))
+          do (setf (slot req 'tv-sec) (slot rem 'tv-sec)
+                   (slot req 'tv-nsec) (slot rem 'tv-nsec)))))
 
 (defun unix-get-seconds-west (secs)
   (multiple-value-bind (ignore seconds dst) (get-timezone secs)