X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Ffile.lisp;h=823d32142afcc486222097a34da3248428ae0349;hb=de3bfc084239fa962ef001eaa68e5b6f4b9bbf81;hp=01da23bff2caa94319bb274eef14c05af7dbda34;hpb=d8e0a653d6974279581a3d1a151bde02ea6023c9;p=sbcl.git

diff --git a/contrib/sb-simple-streams/file.lisp b/contrib/sb-simple-streams/file.lisp
index 01da23b..823d321 100644
--- a/contrib/sb-simple-streams/file.lisp
+++ b/contrib/sb-simple-streams/file.lisp
@@ -152,15 +152,18 @@
 
 (defmethod device-close ((stream file-simple-stream) abort)
   (with-stream-class (file-simple-stream stream)
-    (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
-      (when (sb-int:fixnump fd)
+    (let ((fd (or (sm input-handle stream) (sm output-handle stream)))
+          (closed nil))
+      (when (integerp fd)
         (cond (abort
                (when (any-stream-instance-flags stream :output)
+                 #+win32 (progn (sb-unix:unix-close fd) (setf closed t))
                  (revert-file (sm filename stream) (sm original stream))))
               (t
                (when (sm delete-original stream)
                  (delete-original (sm filename stream) (sm original stream)))))
-        (sb-unix:unix-close fd))
+        (unless closed
+          (sb-unix:unix-close fd)))
       (when (sm buffer stream)
         (free-buffer (sm buffer stream))
         (setf (sm buffer stream) nil))))
@@ -169,7 +172,7 @@
 (defmethod device-file-position ((stream file-simple-stream))
   (with-stream-class (file-simple-stream stream)
     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
-      (if (sb-int:fixnump fd)
+      (if (integerp fd)
           (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr))
           (file-position fd)))))
 
@@ -177,7 +180,7 @@
   (declare (type fixnum value))
   (with-stream-class (file-simple-stream stream)
     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
-      (if (sb-int:fixnump fd)
+      (if (integerp fd)
           (values (sb-unix:unix-lseek fd
                                       (if (minusp value) (1+ value) value)
                                       (if (minusp value) sb-unix:l_xtnd sb-unix:l_set)))
@@ -186,7 +189,7 @@
 (defmethod device-file-length ((stream file-simple-stream))
   (with-stream-class (file-simple-stream stream)
     (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
-      (if (sb-int:fixnump fd)
+      (if (integerp fd)
           (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
               (sb-unix:unix-fstat (sm input-handle stream))
             (declare (ignore dev ino mode nlink uid gid rdev))
@@ -201,7 +204,7 @@
              (prot (logior (if input sb-posix::PROT-READ 0)
                            (if output sb-posix::PROT-WRITE 0)))
              (fd (or (sm input-handle stream) (sm output-handle stream))))
-        (unless (sb-int:fixnump fd)
+        (unless (integerp fd)
           (error "Can't memory-map an encapsulated stream."))
         (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
             (sb-unix:unix-fstat fd)
@@ -222,9 +225,20 @@
             (warn "Unable to memory-map entire file.")
             (setf size (1- most-positive-fixnum)))
           (let ((buffer
+                 #-win32
                  (handler-case
-                  (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
-                  (sb-posix:syscall-error nil))))
+                     (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
+                   (sb-posix:syscall-error nil))
+                 #+win32
+                 (let ((mapping
+                        (sb-win32:create-file-mapping
+                         (sb-win32:get-osfhandle fd) nil 2 0 size nil)))
+                   (typecase mapping
+                     ((integer -1 0) nil)
+                     (t (let ((sap (prog1 (sb-win32:map-view-of-file
+                                           mapping 4 0 0 size)
+                                     (sb-win32:close-handle mapping))))
+                          (and (not (zerop (sb-sys:sap-int sap))) sap)))))))
             (when (null buffer)
               (sb-unix:unix-close fd)
               (sb-ext:cancel-finalization stream)
@@ -244,7 +258,8 @@
                (melding-stream stream) efmt 'mapped))
             (sb-ext:finalize stream
               (lambda ()
-                (sb-posix:munmap buffer size)
+                #+win32 (sb-win32:unmap-view-of-file buffer)
+                #-win32 (sb-posix:munmap buffer size)
                 (format *terminal-io* "~&;;; ** unmapped ~S" buffer))
               :dont-save t))))
       stream)))
@@ -253,7 +268,8 @@
 (defmethod device-close ((stream mapped-file-simple-stream) abort)
   (with-stream-class (mapped-file-simple-stream stream)
     (when (sm buffer stream)
-      (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
+      #+win32 (sb-win32:unmap-view-of-file (sm buffer stream))
+      #-win32 (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
       (setf (sm buffer stream) nil))
     (sb-unix:unix-close (or (sm input-handle stream) (sm output-handle stream))))
   t)