X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Finternal.lisp;h=6f956e9ada92539820845081c3cedd7c59790ab0;hb=f057566fe993f008a9b34dc87b026e7c8ef2611d;hp=dacfb861a70b68a6554a8b92df9c6a102e0bcad4;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp
index dacfb86..6f956e9 100644
--- a/contrib/sb-simple-streams/internal.lisp
+++ b/contrib/sb-simple-streams/internal.lisp
@@ -28,7 +28,8 @@
   (declare (type simple-stream-buffer buffer)
            (type (integer 0 #.most-positive-fixnum) index))
   (if (vectorp buffer)
-      (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index)
+      (sb-sys:with-pinned-objects (buffer)
+        (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index))
       (sb-sys:sap-ref-8 buffer index)))
 
 (defun (setf bref) (octet buffer index)
@@ -36,28 +37,26 @@
            (type simple-stream-buffer buffer)
            (type (integer 0 #.most-positive-fixnum) index))
   (if (vectorp buffer)
-      (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet)
+      (sb-sys:with-pinned-objects (buffer)
+        (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet))
       (setf (sb-sys:sap-ref-8 buffer index) octet)))
 
 (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))
@@ -332,14 +331,15 @@
                     (tagbody
                      again
                        ;; Avoid CMUCL gengc write barrier
-                       (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
+                       (do ((i start (+ i #.(sb-posix:getpagesize))))
                            ((>= i end))
                          (declare (type fixnum i))
                          (setf (bref buffer i) 0))
                        (setf (bref buffer (1- end)) 0)
                        (multiple-value-bind (bytes errno)
-                           (sb-unix:unix-read fd (buffer-sap buffer start)
-                                              (the fixnum (- end start)))
+                           (sb-sys:with-pinned-objects (buffer)
+                             (sb-unix:unix-read fd (buffer-sap buffer start)
+                                                (the fixnum (- end start))))
                          (declare (type (or null fixnum) bytes)
                                   (type (integer 0 100) errno))
                          (when bytes
@@ -388,8 +388,9 @@
                 (let ((count 0))
                   (tagbody again
                      (multiple-value-bind (bytes errno)
-                         (sb-unix:unix-write fd (buffer-sap buffer) start
-                                          (- end start))
+                         (sb-sys:with-pinned-objects (buffer)
+                           (sb-unix:unix-write fd (buffer-sap buffer) start
+                                               (- end start)))
                        (when bytes
                          (incf count bytes)
                          (incf start bytes))
@@ -419,7 +420,8 @@
                      (type sb-int:index start end len))
             (tagbody again
                (multiple-value-bind (bytes errno)
-                   (sb-unix:unix-write fd (buffer-sap buffer) start len)
+                   (sb-sys:with-pinned-objects (buffer)
+                     (sb-unix:unix-write fd (buffer-sap buffer) start len))
                  (cond ((null bytes)
                         (if (= errno sb-unix:eintr)
                             (go again)
@@ -471,11 +473,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
@@ -621,8 +626,7 @@
            (type (member :input :output :io :probe) direction)
            (type (member :error :new-version :rename :rename-and-delete
                          :overwrite :append :supersede nil) if-exists)
-           (type (member :error :create nil) if-does-not-exist)
-           (ignore external-format))
+           (type (member :error :create nil) if-does-not-exist))
   (let ((filespec (merge-pathnames pathname)))
     (multiple-value-bind (fd namestring original delete-original)
         (%fd-open filespec direction if-exists if-exists-given
@@ -640,7 +644,8 @@
                                   :pathname pathname
                                   :dual-channel-p nil
                                   :input-buffer-p t
-                                  :auto-close t))
+                                  :auto-close t
+                                  :external-format external-format))
           (:probe
            (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
                                                    :pathname pathname