New function SB-EXT:ASSERT-VERSION->=

[sbcl.git] / contrib / sb-simple-streams / internal.lisp

diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp
index 0aefd13..2067797 100644 (file)
--- a/contrib/sb-simple-streams/internal.lisp
+++ b/contrib/sb-simple-streams/internal.lisp
@@ -44,22 +44,19 @@
 (defun buffer-copy (src soff dst doff length)
   (declare (type simple-stream-buffer src dst)
            (type fixnum soff doff length))
-  (sb-sys:without-gcing ;; is this necessary??
+  ;; FIXME: Should probably be with-pinned-objects
+  (sb-sys:without-gcing
    (sb-kernel:system-area-ub8-copy (buffer-sap src) soff
                                    (buffer-sap dst) doff
                                    length)))
 
 (defun allocate-buffer (size)
-  (if (= size sb-impl::bytes-per-buffer)
-      (sb-impl::next-available-buffer)
-      (make-array size :element-type '(unsigned-byte 8))))
+  (make-array size :element-type '(unsigned-byte 8)))
 
 (defun free-buffer (buffer)
-  (when (sb-sys:system-area-pointer-p buffer)
-    (push buffer sb-impl::*available-buffers*))
+  (sb-int:aver (typep buffer '(simple-array (unsigned-byte 8) (*))))
   t)
 
-
 (defun make-control-table (&rest inits)
   (let ((table (make-array 32 :initial-element nil)))
     (do* ((char (pop inits) (pop inits))
@@ -357,7 +354,11 @@
                                                    ;; eagain into
                                                    ;; sb-unix
                                                    11)
-                                                (= errno sb-unix:ewouldblock)))
+                                                (= errno
+                                                   #-win32
+                                                   sb-unix:ewouldblock
+                                                   #+win32
+                                                   sb-unix:eintr)))
                                        (sb-sys:wait-until-fd-usable fd :input nil)
                                        (go again))
                                       (t (return (- -10 errno)))))
@@ -476,11 +477,14 @@
         (:io (values t t sb-unix:o_rdwr))
         (:probe (values t nil sb-unix:o_rdonly)))
     (declare (type sb-int:index mask))
-    (let ((name (cond ((sb-int:unix-namestring pathname input))
-                      ((and input (eq if-does-not-exist :create))
-                       (sb-int:unix-namestring pathname nil))
-                      ((and (eq direction :io) (not if-does-not-exist-given))
-                       (sb-int:unix-namestring pathname nil)))))
+    (let* ((phys (sb-int:physicalize-pathname (merge-pathnames pathname)))
+           (true (probe-file phys))
+           (name (cond (true
+                        (sb-ext:native-namestring true :as-file t))
+                       ((or (not input)
+                            (and input (eq if-does-not-exist :create))
+                            (and (eq direction :io) (not if-does-not-exist-given)))
+                        (sb-ext:native-namestring phys :as-file t)))))
       ;; Process if-exists argument if we are doing any output.
       (cond (output
              (unless if-exists-given
@@ -564,9 +568,12 @@
         (loop
           (multiple-value-bind (fd errno)
               (if name
+                  #+win32
+                  (sb-win32:unixlike-open name mask mode)
+                  #-win32
                   (sb-unix:unix-open name mask mode)
                   (values nil sb-unix:enoent))
-            (cond ((sb-int:fixnump fd)
+            (cond ((integerp fd)
                    (when (eql if-exists :append)
                      (sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
                    (return (values fd name original delete-original)))