sb-win32: offer low-level bindings for file mapping functions

[sbcl.git] / contrib / sb-posix / interface.lisp

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 5704d3f..f8eef1f 100644 (file)
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -8,7 +8,11 @@
       (export ',name :sb-posix)
       (defclass ,name ,superclasses
         ,(loop for slotd in slots
       (export ',name :sb-posix)
       (defclass ,name ,superclasses
         ,(loop for slotd in slots

-               collect (ldiff slotd (member :array-length slotd)))
+               ;; KLUDGE: Splice out :ARRAY-LENGTH options (they're
+               ;; for the conversion functions, not for DEFCLASS).
+               for array-length-option = (member :array-length slotd)
+               collect (append (ldiff slotd array-length-option)
+                               (cddr array-length-option)))

         ,@options)
       (declaim (inline ,to-alien ,to-protocol))
       (declaim (inline ,to-protocol ,to-alien))
         ,@options)
       (declaim (inline ,to-alien ,to-protocol))
       (declaim (inline ,to-protocol ,to-alien))

@@ -57,29 +61,25 @@
       (find-class ',name))))
 
 (define-condition sb-posix:syscall-error (error)
       (find-class ',name))))
 
 (define-condition sb-posix:syscall-error (error)

-  ((errno :initarg :errno :reader sb-posix:syscall-errno))
+  ((errno :initarg :errno :reader sb-posix:syscall-errno)
+   (name :initarg :name :initform nil :reader sb-posix:syscall-name))

   (:report (lambda (c s)
   (:report (lambda (c s)

-             (let ((errno (sb-posix:syscall-errno c)))
-               (format s "System call error ~A (~A)"
-                       errno (sb-int:strerror errno))))))
-
-(defvar *errno-table*
-  (let ((errno-max 0)
-        list)
-    (do-symbols (symbol (find-package "SB-POSIX"))
-      (when (get symbol 'errno)
-        (let ((errno (symbol-value symbol)))
-          (setf errno-max (max errno  errno-max))
-          (push (cons errno
-                      (eval `(define-condition ,symbol (syscall-error) ())))
-                list))))
-    (let ((table (make-array (1+ errno-max))))
-      (mapc #'(lambda (cons) (setf (elt table (car cons)) (cdr cons))) list)
-      table)))
-
-(defun syscall-error ()
-  (let ((errno (get-errno)))
-    (error (elt *errno-table* errno) :errno errno)))
+             (let ((errno (sb-posix:syscall-errno c))
+                   (name (sb-posix:syscall-name c)))
+               (if name
+                   (format s "Error in ~S: ~A (~A)"
+                           name
+                           (sb-int:strerror errno)
+                           errno)
+                   (format s "Error in syscall: ~A (~A)"
+                           (sb-int:strerror errno)
+                           errno))))))
+
+(declaim (ftype (function (&optional symbol) nil) syscall-error))
+(defun syscall-error (&optional name)
+  (error 'sb-posix:syscall-error
+         :name name
+         :errno (get-errno)))

 
 (defun unsupported-error (lisp-name c-name)
   (error "~S is unsupported by SBCL on this platform due to lack of ~A()."
 
 (defun unsupported-error (lisp-name c-name)
   (error "~S is unsupported by SBCL on this platform due to lack of ~A()."

@@ -89,60 +89,6 @@
   (warn "~S is unsupported by SBCL on this platform due to lack of ~A()."
         lisp-name c-name))
 
   (warn "~S is unsupported by SBCL on this platform due to lack of ~A()."
         lisp-name c-name))
 

-;; Note that we inherit from SIMPLE-FILE-ERROR first, to get its
-;; error reporting, rather than SYSCALL-ERROR's.
-(define-condition file-syscall-error
-    (sb-impl::simple-file-error syscall-error)
-  ())
-
-(defvar *file-errno-table*
-  (let ((array (copy-seq *errno-table*)))
-    (map-into array
-              (lambda (condition-class-name)
-                (if (symbolp condition-class-name)
-                    (let ((file-condition-name
-                           (read-from-string
-                            (format nil "FILE-~A" condition-class-name))))
-                      ;; Should condition class names like FILE-ENOENT
-                      ;; and FILE-ENOTDIR be exported?  I want to say
-                      ;; "no", since we already export ENOENT, ENOTDIR
-                      ;; et al, and so the user can write handlers
-                      ;; such as
-                      ;;
-                      ;;  (handler-bind ((sb-posix:enoent ...)
-                      ;;                 (sb-posix:enotdir ...)
-                      ;;                 (file-error ...))
-                      ;;    ...)
-                      ;;
-                      ;; which will do the right thing for all our
-                      ;; FILE-SYSCALL-ERRORs, without exposing this
-                      ;; implementation detail.  (Recall that some
-                      ;; FILE-ERRORs don't strictly have to do with
-                      ;; the file system, e.g., supplying a wild
-                      ;; pathname to some functions.)  But if the
-                      ;; prevailing opinion is otherwise, uncomment
-                      ;; the following.
-                      #| (export file-condition-name) |#
-                      (eval `(define-condition ,file-condition-name
-                                 (,condition-class-name file-syscall-error)
-                               ())))
-                    condition-class-name))
-              array)
-    array))
-
-;; Note: do we have to declare SIMPLE-FILE-PERROR notinline in
-;; fd-stream.lisp?
-(sb-ext:without-package-locks
-  (defun sb-impl::simple-file-perror (note-format pathname errno)
-    (error (elt *file-errno-table* errno)
-           :pathname pathname
-           :errno errno
-           :format-control "~@<~?: ~2I~_~A~:>"
-           :format-arguments
-           (list note-format (list pathname) (sb-int:strerror errno)))))
-
-;; Note: it might prove convenient to develop a parallel set of
-;; condition classes for STREAM-ERRORs, too.

 (declaim (inline never-fails))
 (defun never-fails (&rest args)
   (declare (ignore args))
 (declaim (inline never-fails))
 (defun never-fails (&rest args)
   (declare (ignore args))

@@ -190,11 +136,24 @@
                        (open-with-mode pathname flags mode)
                        (open-without-mode pathname flags))))))
     (def #-win32 "open" #+win32 "_open"))
                        (open-with-mode pathname flags mode)
                        (open-without-mode pathname flags))))))
     (def #-win32 "open" #+win32 "_open"))

+(define-call* "read" int minusp
+    (fd file-descriptor) (buf (* t)) (count int))

 (define-call "rename" int minusp (oldpath filename) (newpath filename))
 (define-call* "rmdir" int minusp (pathname filename))
 (define-call* "unlink" int minusp (pathname filename))
 (define-call #-netbsd "opendir" #+netbsd "_opendir"
     (* t) null-alien (pathname filename))
 (define-call "rename" int minusp (oldpath filename) (newpath filename))
 (define-call* "rmdir" int minusp (pathname filename))
 (define-call* "unlink" int minusp (pathname filename))
 (define-call #-netbsd "opendir" #+netbsd "_opendir"
     (* t) null-alien (pathname filename))

+(define-call* "write" int minusp
+    (fd file-descriptor) (buf (* t)) (count int))
+#+inode64
+(define-call ("readdir" :c-name "readdir$INODE64" :options :largefile)
+  (* dirent)
+  ;; readdir() has the worst error convention in the world.  It's just
+  ;; too painful to support.  (return is NULL _and_ errno "unchanged"
+  ;; is not an error, it's EOF).
+  not
+  (dir (* t)))
+#-inode64

 (define-call (#-netbsd "readdir" #+netbsd "_readdir" :options :largefile)
   (* dirent)
   ;; readdir() has the worst error convention in the world.  It's just
 (define-call (#-netbsd "readdir" #+netbsd "_readdir" :options :largefile)
   (* dirent)
   ;; readdir() has the worst error convention in the world.  It's just

@@ -238,7 +197,8 @@
                         (let* ((external-format sb-alien::*default-c-string-external-format*)
                                (arg (sb-ext:string-to-octets
                                      (filename template)
                         (let* ((external-format sb-alien::*default-c-string-external-format*)
                                (arg (sb-ext:string-to-octets
                                      (filename template)

-                                     :external-format external-format)))
+                                     :external-format external-format
+                                     :null-terminate t)))

                           (sb-sys:with-pinned-objects (arg)
                             ;; accommodate for the call-by-reference
                             ;; nature of mks/dtemp's template strings.
                           (sb-sys:with-pinned-objects (arg)
                             ;; accommodate for the call-by-reference
                             ;; nature of mks/dtemp's template strings.

@@ -246,11 +206,12 @@
                                                                        (function ,result-type system-area-pointer))
                                                          (sb-alien::vector-sap arg))))
                               (when (,errorp result)
                                                                        (function ,result-type system-area-pointer))
                                                          (sb-alien::vector-sap arg))))
                               (when (,errorp result)

-                                (syscall-error))
+                                (syscall-error ',lisp-name))

                               ;; FIXME: We'd rather return pathnames, but other
                               ;; SB-POSIX functions like this return strings...
                               (let ((pathname (sb-ext:octets-to-string
                               ;; FIXME: We'd rather return pathnames, but other
                               ;; SB-POSIX functions like this return strings...
                               (let ((pathname (sb-ext:octets-to-string

-                                               arg :external-format external-format)))
+                                               arg :external-format external-format
+                                               :end (1- (length arg)))))

                                 ,(if values
                                      '(values result pathname)
                                      'pathname))))))
                                 ,(if values
                                      '(values result pathname)
                                      'pathname))))))

@@ -290,51 +251,78 @@
   (define-call-internally fcntl-with-pointer-arg "fcntl" int minusp
                           (fd file-descriptor) (cmd int)
                           (arg alien-pointer-to-anything-or-nil))
   (define-call-internally fcntl-with-pointer-arg "fcntl" int minusp
                           (fd file-descriptor) (cmd int)
                           (arg alien-pointer-to-anything-or-nil))

+  (define-protocol-class flock alien-flock ()
+   ((type :initarg :type :accessor flock-type
+          :documentation "Type of lock; F_RDLCK, F_WRLCK, F_UNLCK.")
+    (whence :initarg :whence :accessor flock-whence
+            :documentation "Flag for starting offset.")
+    (start :initarg :start :accessor flock-start
+           :documentation "Relative offset in bytes.")
+    (len :initarg :len :accessor flock-len
+         :documentation "Size; if 0 then until EOF.")
+    ;; Note: PID isn't initable, and is read-only.  But other stuff in
+    ;; SB-POSIX right now loses when a protocol-class slot is unbound,
+    ;; so we initialize it to 0.
+    (pid :initform 0 :reader flock-pid
+         :documentation
+         "Process ID of the process holding the lock; returned with F_GETLK."))
+   (:documentation "Class representing locks used in fcntl(2)."))

   (define-entry-point "fcntl" (fd cmd &optional (arg nil argp))
     (if argp
         (etypecase arg
           ((alien int) (fcntl-with-int-arg fd cmd arg))
   (define-entry-point "fcntl" (fd cmd &optional (arg nil argp))
     (if argp
         (etypecase arg
           ((alien int) (fcntl-with-int-arg fd cmd arg))

-          ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg)))
+          ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg))
+          (flock (with-alien-flock a-flock ()
+                   (flock-to-alien arg a-flock)
+                   (let ((r (fcntl-with-pointer-arg fd cmd a-flock)))
+                     (alien-to-flock a-flock arg)
+                     r))))

         (fcntl-without-arg fd cmd)))
 
   ;; uid, gid
   (define-call "geteuid" uid-t never-fails) ; "always successful", it says
         (fcntl-without-arg fd cmd)))
 
   ;; uid, gid
   (define-call "geteuid" uid-t never-fails) ; "always successful", it says

-  (define-call "getresuid" uid-t never-fails)
+#-sunos  (define-call "getresuid" uid-t never-fails)

   (define-call "getuid" uid-t never-fails)
   (define-call "seteuid" int minusp (uid uid-t))
   (define-call "getuid" uid-t never-fails)
   (define-call "seteuid" int minusp (uid uid-t))

-  (define-call "setfsuid" int minusp (uid uid-t))
+#-sunos  (define-call "setfsuid" int minusp (uid uid-t))

   (define-call "setreuid" int minusp (ruid uid-t) (euid uid-t))
   (define-call "setreuid" int minusp (ruid uid-t) (euid uid-t))

-  (define-call "setresuid" int minusp (ruid uid-t) (euid uid-t) (suid uid-t))
+#-sunos  (define-call "setresuid" int minusp (ruid uid-t) (euid uid-t) (suid uid-t))

   (define-call "setuid" int minusp (uid uid-t))
   (define-call "getegid" gid-t never-fails)
   (define-call "getgid" gid-t never-fails)
   (define-call "setuid" int minusp (uid uid-t))
   (define-call "getegid" gid-t never-fails)
   (define-call "getgid" gid-t never-fails)

-  (define-call "getresgid" gid-t never-fails)
+#-sunos  (define-call "getresgid" gid-t never-fails)

   (define-call "setegid" int minusp (gid gid-t))
   (define-call "setegid" int minusp (gid gid-t))

-  (define-call "setfsgid" int minusp (gid gid-t))
+#-sunos  (define-call "setfsgid" int minusp (gid gid-t))

   (define-call "setgid" int minusp (gid gid-t))
   (define-call "setregid" int minusp (rgid gid-t) (egid gid-t))
   (define-call "setgid" int minusp (gid gid-t))
   (define-call "setregid" int minusp (rgid gid-t) (egid gid-t))

-  (define-call "setresgid" int minusp (rgid gid-t) (egid gid-t) (sgid gid-t))
+#-sunos  (define-call "setresgid" int minusp (rgid gid-t) (egid gid-t) (sgid gid-t))

 
   ;; processes, signals
   (define-call "alarm" int never-fails (seconds unsigned))
 
 
 
 
   ;; processes, signals
   (define-call "alarm" int never-fails (seconds unsigned))
 
 
 

+  ;; FIXME this is a lie, of course this can fail, but there's no
+  ;; error handling here yet!

   #+mach-exception-handler
   #+mach-exception-handler

-  (progn
-    ;; FIXME this is a lie, of course this can fail, but there's no
-    ;; error handling here yet!
-    (define-call "setup_mach_exceptions" void never-fails)
-    (define-call ("posix_fork" :c-name "fork") pid-t minusp)
-    (defun fork ()
-      (let ((pid (posix-fork)))
-        (when (= pid 0)
-          (setup-mach-exceptions))
-        pid))
-    (export 'fork :sb-posix))
-
-  #-mach-exception-handler
-  (define-call "fork" pid-t minusp)
+  (define-call "setup_mach_exceptions" void never-fails)
+  (define-call ("posix_fork" :c-name "fork") pid-t minusp)
+  (defun fork ()
+    "Forks the current process, returning 0 in the new process and the PID of
+the child process in the parent. Forking while multiple threads are running is
+not supported."
+    (tagbody
+       (sb-thread::with-all-threads-lock
+         (when (cdr sb-thread::*all-threads*)
+           (go :error))
+         (let ((pid (posix-fork)))
+           #+mach-exception-handler
+           (when (= pid 0)
+             (setup-mach-exceptions))
+           (return-from fork pid)))
+     :error
+       (error "Cannot fork with multiple threads running.")))
+  (export 'fork :sb-posix)

 
   (define-call "getpgid" pid-t minusp (pid pid-t))
   (define-call "getppid" pid-t never-fails)
 
   (define-call "getpgid" pid-t minusp (pid pid-t))
   (define-call "getppid" pid-t never-fails)

@@ -344,7 +332,8 @@
   (define-call "killpg" int minusp (pgrp int) (signal int))
   (define-call "pause" int minusp)
   (define-call "setpgid" int minusp (pid pid-t) (pgid pid-t))
   (define-call "killpg" int minusp (pgrp int) (signal int))
   (define-call "pause" int minusp)
   (define-call "setpgid" int minusp (pid pid-t) (pgid pid-t))

-  (define-call "setpgrp" int minusp))
+  (define-call "setpgrp" int minusp)
+  (define-call "setsid" pid-t minusp))

 
 (defmacro with-growing-c-string ((buffer size) &body body)
   (sb-int:with-unique-names (c-string-block)
 
 (defmacro with-growing-c-string ((buffer size) &body body)
   (sb-int:with-unique-names (c-string-block)

@@ -374,12 +363,12 @@
     "Returns the resolved target of a symbolic link as a string."
     (flet ((%readlink (path buf length)
              (alien-funcall
     "Returns the resolved target of a symbolic link as a string."
     (flet ((%readlink (path buf length)
              (alien-funcall

-              (extern-alien "readlink" (function int c-string (* t) int))
+              (extern-alien "readlink" (function int (c-string :not-null t) (* t) int))

               path buf length)))
       (with-growing-c-string (buf size)
         (let ((count (%readlink (filename pathspec) buf size)))
           (cond ((minusp count)
               path buf length)))
       (with-growing-c-string (buf size)
         (let ((count (%readlink (filename pathspec) buf size)))
           (cond ((minusp count)

-                 (syscall-error))
+                 (syscall-error 'readlink))

                 ((< 0 count size)
                  (buf count))))))))
 
                 ((< 0 count size)
                  (buf count))))))))
 

@@ -397,7 +386,7 @@
           (cond (result
                  (buf))
                 ((/= (get-errno) sb-posix:erange)
           (cond (result
                  (buf))
                 ((/= (get-errno) sb-posix:erange)

-                 (syscall-error))))))))
+                 (syscall-error 'getcwd))))))))

 
 #-win32
 (progn
 
 #-win32
 (progn

@@ -411,7 +400,7 @@
                   (extern-alien "wait" (function pid-t (* int)))
                   (sb-sys:vector-sap ptr)))))
      (if (minusp pid)
                   (extern-alien "wait" (function pid-t (* int)))
                   (sb-sys:vector-sap ptr)))))
      (if (minusp pid)

-         (syscall-error)
+         (syscall-error 'wait)

          (values pid (aref ptr 0))))))
 
 #-win32
          (values pid (aref ptr 0))))))
 
 #-win32

@@ -429,7 +418,7 @@
                                                     pid-t (* int) int))
                   pid (sb-sys:vector-sap ptr) options))))
      (if (minusp pid)
                                                     pid-t (* int) int))
                   pid (sb-sys:vector-sap ptr) options))))
      (if (minusp pid)

-         (syscall-error)
+         (syscall-error 'waitpid)

          (values pid (aref ptr 0)))))
  ;; waitpid macros
  (define-call "wifexited" boolean never-fails (status int))
          (values pid (aref ptr 0)))))
  ;; waitpid macros
  (define-call "wifexited" boolean never-fails (status int))

@@ -453,8 +442,33 @@
  (define-call "munmap" int minusp
    (start sb-sys:system-area-pointer) (length unsigned))
 
  (define-call "munmap" int minusp
    (start sb-sys:system-area-pointer) (length unsigned))
 

+#-win32

 (define-call "msync" int minusp
   (addr sb-sys:system-area-pointer) (length unsigned) (flags int)))
 (define-call "msync" int minusp
   (addr sb-sys:system-area-pointer) (length unsigned) (flags int)))

+#+win32
+(progn
+  ;; No attempt is made to offer a full mmap-like interface on Windows.
+  ;; It would be possible to do so (and has been done by AK on his
+  ;; branch), but the use case is unclear to me.  However, the following
+  ;; definitions are needed to keep existing code in sb-simple-streams
+  ;; running. --DFL
+  (defconstant PROT-READ #x02)
+  (defconstant PROT-WRITE #x04)
+  (defconstant PROT-EXEC #x10)
+  (defconstant PROT-NONE 0)
+  (defconstant MAP-SHARED 0)
+  (defconstant MAP-PRIVATE 1)
+  (defconstant MS-ASYNC nil)
+  (defconstant MS-SYNC nil)
+  (export                            ;export on the fly like define-call
+   (defun msync (address length flags)
+     (declare (ignore flags))
+     (when (zerop (sb-win32:flush-view-of-file address length))
+       (sb-win32::win32-error "FlushViewOfFile")))))
+
+;;; mlockall, munlockall
+(define-call "mlockall" int minusp (flags int))
+(define-call "munlockall" int minusp)

 
 #-win32
 (define-call "getpagesize" int minusp)
 
 #-win32
 (define-call "getpagesize" int minusp)

@@ -486,22 +500,6 @@
   (:documentation "Instances of this class represent entries in
                    the system's user database."))
 
   (:documentation "Instances of this class represent entries in
                    the system's user database."))
 

-(defmacro define-pw-call (name arg type)
-  #-win32
-  ;; FIXME: this isn't the documented way of doing this, surely?
-  (let ((lisp-name (intern (string-upcase name) :sb-posix)))
-    `(progn
-      (export ',lisp-name :sb-posix)
-      (declaim (inline ,lisp-name))
-      (defun ,lisp-name (,arg)
-        (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
-          (if (null-alien r)
-              nil
-              (alien-to-passwd r)))))))
-
-(define-pw-call "getpwnam" login-name (function (* alien-passwd) c-string))
-(define-pw-call "getpwuid" uid (function (* alien-passwd) uid-t))
-

 ;;; group database
 #-win32
 (define-protocol-class group alien-group ()
 ;;; group database
 #-win32
 (define-protocol-class group alien-group ()

@@ -509,7 +507,7 @@
    (passwd :initarg :passwd :accessor group-passwd)
    (gid :initarg :gid :accessor group-gid)))
 
    (passwd :initarg :passwd :accessor group-passwd)
    (gid :initarg :gid :accessor group-gid)))
 

-(defmacro define-gr-call (name arg type)
+(defmacro define-obj-call (name arg type conv)

   #-win32
   ;; FIXME: this isn't the documented way of doing this, surely?
   (let ((lisp-name (intern (string-upcase name) :sb-posix)))
   #-win32
   ;; FIXME: this isn't the documented way of doing this, surely?
   (let ((lisp-name (intern (string-upcase name) :sb-posix)))

@@ -520,10 +518,16 @@
         (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
           (if (null-alien r)
               nil
         (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
           (if (null-alien r)
               nil

-              (alien-to-group r)))))))
+              (,conv r)))))))

 
 

-(define-gr-call "getgrnam" login-name (function (* alien-group) c-string))
-(define-gr-call "getgrgid" gid (function (* alien-group) gid-t))
+(define-obj-call "getpwnam" login-name (function (* alien-passwd) (c-string :not-null t))
+                 alien-to-passwd)
+(define-obj-call "getpwuid" uid (function (* alien-passwd) uid-t)
+                 alien-to-passwd)
+(define-obj-call "getgrnam" login-name (function (* alien-group) (c-string :not-null t))
+                 alien-to-group)
+(define-obj-call "getgrgid" gid (function (* alien-group) gid-t)
+                 alien-to-group)

 
 
 #-win32
 
 
 #-win32

@@ -552,6 +556,8 @@
                          bytes.  For symbolic links, the length
                          in bytes of the filename contained in
                          the symbolic link.")
                          bytes.  For symbolic links, the length
                          in bytes of the filename contained in
                          the symbolic link.")

+   (rdev :initarg :rdev :reader stat-rdev
+          :documentation "For devices the device number.")

    (atime :initarg :atime :reader stat-atime
           :documentation "Time of last access.")
    (mtime :initarg :mtime :reader stat-mtime
    (atime :initarg :atime :reader stat-atime
           :documentation "Time of last access.")
    (mtime :initarg :mtime :reader stat-mtime

@@ -563,7 +569,9 @@
 
 (defmacro define-stat-call (name arg designator-fun type)
   ;; FIXME: this isn't the documented way of doing this, surely?
 
 (defmacro define-stat-call (name arg designator-fun type)
   ;; FIXME: this isn't the documented way of doing this, surely?

-  (let ((lisp-name (lisp-for-c-symbol name)))
+  (let ((lisp-name (lisp-for-c-symbol name))
+        (real-name #+inode64 (format nil "~A$INODE64" name)
+                   #-inode64 name))

     `(progn
       (export ',lisp-name :sb-posix)
       (declaim (inline ,lisp-name))
     `(progn
       (export ',lisp-name :sb-posix)
       (declaim (inline ,lisp-name))

@@ -571,21 +579,21 @@
         (declare (type (or null stat) stat))
         (with-alien-stat a-stat ()
           (let ((r (alien-funcall
         (declare (type (or null stat) stat))
         (with-alien-stat a-stat ()
           (let ((r (alien-funcall

-                    (extern-alien ,(real-c-name (list name :options :largefile)) ,type)
+                    (extern-alien ,(real-c-name (list real-name :options :largefile)) ,type)

                     (,designator-fun ,arg)
                     a-stat)))
             (when (minusp r)
                     (,designator-fun ,arg)
                     a-stat)))
             (when (minusp r)

-              (syscall-error))
+              (syscall-error ',lisp-name))

             (alien-to-stat a-stat stat)))))))
 
 (define-stat-call #-win32 "stat" #+win32 "_stat"
                   pathname filename
             (alien-to-stat a-stat stat)))))))
 
 (define-stat-call #-win32 "stat" #+win32 "_stat"
                   pathname filename

-                  (function int c-string (* alien-stat)))
+                  (function int (c-string :not-null t) (* alien-stat)))

 
 #-win32
 (define-stat-call "lstat"
                   pathname filename
 
 #-win32
 (define-stat-call "lstat"
                   pathname filename

-                  (function int c-string (* alien-stat)))
+                  (function int (c-string :not-null t) (* alien-stat)))

 ;;; No symbolic links on Windows, so use stat
 #+win32
 (progn
 ;;; No symbolic links on Windows, so use stat
 #+win32
 (progn

@@ -621,7 +629,7 @@
                (extern-alien "pipe" (function int (* int)))
                (sb-sys:vector-sap filedes2)))))
      (when (minusp r)
                (extern-alien "pipe" (function int (* int)))
                (sb-sys:vector-sap filedes2)))))
      (when (minusp r)

-       (syscall-error)))
+       (syscall-error 'pipe)))

    (values (aref filedes2 0) (aref filedes2 1))))
 
 #-win32
    (values (aref filedes2 0) (aref filedes2 1))))
 
 #-win32

@@ -635,7 +643,7 @@
    (lflag :initarg :lflag :accessor sb-posix:termios-lflag
           :documentation "Local modes.")
    (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs
    (lflag :initarg :lflag :accessor sb-posix:termios-lflag
           :documentation "Local modes.")
    (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs

-       :documentation "Control characters"))
+       :documentation "Control characters."))

   (:documentation "Instances of this class represent I/O
                    characteristics of the terminal."))
 
   (:documentation "Instances of this class represent I/O
                    characteristics of the terminal."))
 

@@ -654,7 +662,7 @@
                    (function int int int (* alien-termios)))
                   fd actions a-termios)))
          (when (minusp r)
                    (function int int int (* alien-termios)))
                   fd actions a-termios)))
          (when (minusp r)

-           (syscall-error)))
+           (syscall-error 'tcsetattr)))

        (values))))
  (export 'tcgetattr :sb-posix)
  (declaim (inline tcgetattr))
        (values))))
  (export 'tcgetattr :sb-posix)
  (declaim (inline tcgetattr))

@@ -667,9 +675,14 @@
                (file-descriptor fd)
                a-termios)))
        (when (minusp r)
                (file-descriptor fd)
                a-termios)))
        (when (minusp r)

-         (syscall-error))
+         (syscall-error 'tcgetattr))

        (setf termios (alien-to-termios a-termios termios))))
    termios)
        (setf termios (alien-to-termios a-termios termios))))
    termios)

+ (define-call "tcdrain" int minusp (fd file-descriptor))
+ (define-call "tcflow" int minusp (fd file-descriptor) (action int))
+ (define-call "tcflush" int minusp (fd file-descriptor) (queue-selector int))
+ (define-call "tcgetsid" pid-t minusp (fd file-descriptor))
+ (define-call "tcsendbreak" int minusp (fd file-descriptor) (duration int))

  (export 'cfsetispeed :sb-posix)
  (declaim (inline cfsetispeed))
  (defun cfsetispeed (speed &optional termios)
  (export 'cfsetispeed :sb-posix)
  (declaim (inline cfsetispeed))
  (defun cfsetispeed (speed &optional termios)

@@ -681,7 +694,7 @@
                a-termios
                speed)))
        (when (minusp r)
                a-termios
                speed)))
        (when (minusp r)

-         (syscall-error))
+         (syscall-error 'cfsetispeed))

        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (export 'cfsetospeed :sb-posix)
        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (export 'cfsetospeed :sb-posix)

@@ -695,7 +708,7 @@
                a-termios
                speed)))
        (when (minusp r)
                a-termios
                speed)))
        (when (minusp r)

-         (syscall-error))
+         (syscall-error 'cfsetospeed))

        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (export 'cfgetispeed :sb-posix)
        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (export 'cfgetispeed :sb-posix)

@@ -726,11 +739,11 @@
                                                (function time-t (* time-t)))
                                  nil)))
       (if (minusp result)
                                                (function time-t (* time-t)))
                                  nil)))
       (if (minusp result)

-          (syscall-error)
+          (syscall-error 'time)

           result)))
   (export 'utime :sb-posix)
   (defun utime (filename &optional access-time modification-time)
           result)))
   (export 'utime :sb-posix)
   (defun utime (filename &optional access-time modification-time)

-    (let ((fun (extern-alien "utime" (function int c-string
+    (let ((fun (extern-alien "utime" (function int (c-string :not-null t)

                                                (* alien-utimbuf))))
           (name (filename filename)))
       (if (not (and access-time modification-time))
                                                (* alien-utimbuf))))
           (name (filename filename)))
       (if (not (and access-time modification-time))

@@ -740,7 +753,7 @@
                   (slot utimbuf 'modtime) (or modification-time 0))
             (let ((result (alien-funcall fun name (alien-sap utimbuf))))
               (if (minusp result)
                   (slot utimbuf 'modtime) (or modification-time 0))
             (let ((result (alien-funcall fun name (alien-sap utimbuf))))
               (if (minusp result)

-                  (syscall-error)
+                  (syscall-error 'utime)

                   result))))))
   (export 'utimes :sb-posix)
   (defun utimes (filename &optional access-time modification-time)
                   result))))))
   (export 'utimes :sb-posix)
   (defun utimes (filename &optional access-time modification-time)

@@ -750,9 +763,9 @@
                (values integer (cl:truncate (* fractional 1000000)))))
            (maybe-syscall-error (value)
              (if (minusp value)
                (values integer (cl:truncate (* fractional 1000000)))))
            (maybe-syscall-error (value)
              (if (minusp value)

-                 (syscall-error)
+                 (syscall-error 'utimes)

                  value)))
                  value)))

-      (let ((fun (extern-alien "utimes" (function int c-string
+      (let ((fun (extern-alien "utimes" (function int (c-string :not-null t)

                                                   (* (array alien-timeval 2)))))
             (name (filename filename)))
         (if (not (and access-time modification-time))
                                                   (* (array alien-timeval 2)))))
             (name (filename filename)))
         (if (not (and access-time modification-time))

@@ -772,15 +785,54 @@
 
 ;;; environment
 
 
 ;;; environment
 

-(export 'getenv :sb-posix)
+(eval-when (:compile-toplevel :load-toplevel)
+  ;; Do this at compile-time as Win32 code below refers to it as
+  ;; sb-posix:getenv.
+  (export 'getenv :sb-posix))

 (defun getenv (name)
   (let ((r (alien-funcall
 (defun getenv (name)
   (let ((r (alien-funcall

-            (extern-alien "getenv" (function (* char) c-string))
+            (extern-alien "getenv" (function (* char) (c-string :not-null t)))

             name)))
     (declare (type (alien (* char)) r))
     (unless (null-alien r)
       (cast r c-string))))
             name)))
     (declare (type (alien (* char)) r))
     (unless (null-alien r)
       (cast r c-string))))

-(define-call "putenv" int minusp (string c-string))
+#-win32
+(progn
+  (define-call "setenv" int minusp
+               (name (c-string :not-null t))
+               (value (c-string :not-null t))
+               (overwrite int))
+  (define-call "unsetenv" int minusp (name (c-string :not-null t)))
+  (export 'putenv :sb-posix)
+  (defun putenv (string)
+    (declare (string string))
+    ;; We don't want to call actual putenv: the string passed to putenv ends
+    ;; up in environ, and we any string we allocate GC might move.
+    ;;
+    ;; This makes our wrapper nonconformant if you squit hard enough, but
+    ;; users who care about that should really be calling putenv() directly in
+    ;; order to be able to manage memory sanely.
+    (let ((p (position #\= string))
+          (n (length string)))
+      (if p
+          (if (= p n)
+              (unsetenv (subseq string 0 p))
+              (setenv (subseq string 0 p) (subseq string (1+ p)) 1))
+          (error "Invalid argument to putenv: ~S" string)))))
+#+win32
+(progn
+  ;; Windows doesn't define a POSIX setenv, but happily their _putenv is sane.
+  (define-call* "putenv" int minusp (string (c-string :not-null t)))
+  (export 'setenv :sb-posix)
+  (defun setenv (name value overwrite)
+    (declare (string name value))
+    (if (and (zerop overwrite) (sb-posix:getenv name))
+        0
+        (putenv (concatenate 'string name "=" value))))
+  (export 'unsetenv :sb-posix)
+  (defun unsetenv (name)
+    (declare (string name))
+    (putenv (concatenate 'string name "="))))

 
 ;;; syslog
 #-win32
 
 ;;; syslog
 #-win32

@@ -790,7 +842,7 @@
   (export 'closelog :sb-posix)
   (defun openlog (ident options &optional (facility log-user))
     (alien-funcall (extern-alien
   (export 'closelog :sb-posix)
   (defun openlog (ident options &optional (facility log-user))
     (alien-funcall (extern-alien

-                    "openlog" (function void c-string int int))
+                    "openlog" (function void (c-string :not-null t) int int))

                    ident options facility))
   (defun syslog (priority format &rest args)
     "Send a message to the syslog facility, with severity level
                    ident options facility))
   (defun syslog (priority format &rest args)
     "Send a message to the syslog facility, with severity level

@@ -798,7 +850,9 @@ PRIORITY.  The message will be formatted as by CL:FORMAT (rather
 than C's printf) with format string FORMAT and arguments ARGS."
     (flet ((syslog1 (priority message)
              (alien-funcall (extern-alien
 than C's printf) with format string FORMAT and arguments ARGS."
     (flet ((syslog1 (priority message)
              (alien-funcall (extern-alien

-                             "syslog" (function void int c-string c-string))
+                             "syslog" (function void int
+                                                (c-string :not-null t)
+                                                (c-string :not-null t)))

                             priority "%s" message)))
       (syslog1 priority (apply #'format nil format args))))
   (define-call "closelog" void never-fails))
                             priority "%s" message)))
       (syslog1 priority (apply #'format nil format args))))
   (define-call "closelog" void never-fails))