X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=contrib%2Fsb-simple-streams%2Ffile.lisp;h=5602b28a25cf45f83c674ed87c17e428c2e23825;hb=5d3ffab45b1bb78be7f1767e1e439d8f661ab796;hp=7b71b9dcbd19be84fa2f5830c70517910fcaabca;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/contrib/sb-simple-streams/file.lisp b/contrib/sb-simple-streams/file.lisp index 7b71b9d..5602b28 100644 --- a/contrib/sb-simple-streams/file.lisp +++ b/contrib/sb-simple-streams/file.lisp @@ -80,7 +80,8 @@ (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%" namestring fd) (when original - (revert-file namestring original)))) + (revert-file namestring original))) + :dont-save t) stream))))))) (defmethod device-open ((stream file-simple-stream) options) @@ -115,8 +116,8 @@ ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine ;;; as well, snarf error reporting from there. (defun revert-file (filename original) - (declare (type simple-base-string filename) - (type (or simple-base-string null) original)) + (declare (type simple-string filename) + (type (or simple-string null) original)) ;; We can't do anything unless we know what file were ;; dealing with, and we don't want to do anything ;; strange unless we were writing to the file. @@ -140,8 +141,8 @@ ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine ;;; as well, snarf error reporting from there. (defun delete-original (filename original) - (declare (type simple-base-string filename) - (type (or simple-base-string null) original)) + (declare (type simple-string filename) + (type (or simple-string null) original)) (when original (multiple-value-bind (okay err) (sb-unix:unix-unlink original) (unless okay @@ -151,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)))) @@ -168,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))))) @@ -176,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))) @@ -185,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)) @@ -200,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) @@ -221,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) @@ -243,15 +258,18 @@ (melding-stream stream) efmt 'mapped)) (sb-ext:finalize stream (lambda () - (sb-posix:munmap buffer size) - (format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))) + #+win32 (sb-win32:unmap-view-of-file buffer) + #-win32 (sb-posix:munmap buffer size) + (format *terminal-io* "~&;;; ** unmapped ~S" buffer)) + :dont-save t)))) stream))) (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) @@ -267,6 +285,6 @@ (let ((pathname (getf options :filename))) (with-stream-class (probe-simple-stream stream) (add-stream-instance-flags stream :simple) - (when (sb-unix:unix-access (sb-int:unix-namestring pathname nil) sb-unix:f_ok) + (when (sb-unix:unix-access (%file-namestring pathname) sb-unix:f_ok) (setf (sm pathname stream) pathname) t))))