X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-posix%2Finterface.lisp;h=802593030993f55b07abe3bcf91d5df329b5924e;hb=a37b7e2a4c93398af954c3f03c5412ead1c1c828;hp=732922e08f10bc8338df1107963bfa7e6ffc3894;hpb=ffb003f5648f1abe64561c8a426878774e10a21b;p=sbcl.git

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 732922e..8025930 100644
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -64,14 +64,19 @@
   ((errno :initarg :errno :reader sb-posix:syscall-errno)
    (name :initarg :name :initform nil :reader sb-posix:syscall-name))
   (:report (lambda (c s)
-             (let ((errno (sb-posix:syscall-errno c)))
-               (format s "Error in ~S: ~A (~A)"
-                       (sb-posix:syscall-name c)
-                       (sb-int:strerror errno)
-                       errno)))))
-
-(declaim (ftype (function (symbol) nil) syscall-error))
-(defun syscall-error (name)
+             (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)))
@@ -276,26 +281,35 @@
 
   ;; uid, gid
   (define-call "geteuid" uid-t never-fails) ; "always successful", it says
-#-sunos  (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))
-#-sunos  (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))
-#-sunos  (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)
-#-sunos  (define-call "getresgid" gid-t never-fails)
+  #-sunos
+  (define-call "getresgid" gid-t never-fails)
   (define-call "setegid" int minusp (gid gid-t))
-#-sunos  (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))
-#-sunos  (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))
 
-
+  ;; exit and abort, not much point inlining these
+  (define-simple-call abort void)
+  (define-simple-call exit void (status int))
+  (define-simple-call _exit void (status int))
 
   ;; FIXME this is a lie, of course this can fail, but there's no
   ;; error handling here yet!
@@ -437,8 +451,29 @@ not supported."
  (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)))
+#+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))
@@ -717,8 +752,9 @@ not supported."
           result)))
   (export 'utime :sb-posix)
   (defun utime (filename &optional access-time modification-time)
-    (let ((fun (extern-alien "utime" (function int (c-string :not-null t)
-                                               (* alien-utimbuf))))
+    (let ((fun (extern-alien #-netbsd "utime" #+netbsd "_utime"
+                             (function int (c-string :not-null t)
+                                       (* alien-utimbuf))))
           (name (filename filename)))
       (if (not (and access-time modification-time))
           (alien-funcall fun name nil)