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 ac580c7..f8eef1f 100644 (file)
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -61,14 +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))))))
-
-(defun syscall-error ()
-  (error 'sb-posix:syscall-error :errno (get-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()."

@@ -195,7 +206,7 @@
                                                                        (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

@@ -357,7 +368,7 @@ not supported."
       (with-growing-c-string (buf size)
         (let ((count (%readlink (filename pathspec) buf size)))
           (cond ((minusp count)
       (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))))))))
 

@@ -375,7 +386,7 @@ not supported."
           (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

@@ -389,7 +400,7 @@ not supported."
                   (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

@@ -407,7 +418,7 @@ not supported."
                                                     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))

@@ -431,8 +442,29 @@ not supported."
  (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))
 
 ;;; mlockall, munlockall
 (define-call "mlockall" int minusp (flags int))

@@ -524,6 +556,8 @@ not supported."
                          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

@@ -549,7 +583,7 @@ not supported."
                     (,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"
             (alien-to-stat a-stat stat)))))))
 
 (define-stat-call #-win32 "stat" #+win32 "_stat"

@@ -595,7 +629,7 @@ not supported."
                (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

@@ -628,7 +662,7 @@ not supported."
                    (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))

@@ -641,7 +675,7 @@ not supported."
                (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)
  (define-call "tcdrain" int minusp (fd file-descriptor))
        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (define-call "tcdrain" int minusp (fd file-descriptor))

@@ -660,7 +694,7 @@ not supported."
                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)

@@ -674,7 +708,7 @@ not supported."
                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)

@@ -705,7 +739,7 @@ not supported."
                                                (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)

@@ -719,7 +753,7 @@ not supported."
                   (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)

@@ -729,7 +763,7 @@ not supported."
                (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)))
       (let ((fun (extern-alien "utimes" (function int (c-string :not-null t)
                                                   (* (array alien-timeval 2)))))
                  value)))
       (let ((fun (extern-alien "utimes" (function int (c-string :not-null t)
                                                   (* (array alien-timeval 2)))))