1.0.28.19: faster ARRAY-DIMENSION for non-vectors

[sbcl.git] / src / code / stream.lisp

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 245e47e..4158071 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -939,7 +939,6 @@
 
 (macrolet ((in-fun (name fun &rest args)
              `(defun ,name (stream ,@args)
-                (force-output (two-way-stream-output-stream stream))
                 (,fun (two-way-stream-input-stream stream) ,@args))))
   (in-fun two-way-in read-char eof-error-p eof-value)
   (in-fun two-way-bin read-byte eof-error-p eof-value)
@@ -1082,7 +1081,7 @@
                       (n-bin #'echo-n-bin))
             (:constructor %make-echo-stream (input-stream output-stream))
             (:copier nil))
-  unread-stuff)
+  (unread-stuff nil :type boolean))
 (def!method print-object ((x echo-stream) stream)
   (print-unreadable-object (x stream :type t :identity t)
     (format stream
@@ -1107,47 +1106,55 @@
 
 (macrolet ((in-fun (name in-fun out-fun &rest args)
              `(defun ,name (stream ,@args)
-                (or (pop (echo-stream-unread-stuff stream))
-                    (let* ((in (echo-stream-input-stream stream))
-                           (out (echo-stream-output-stream stream))
-                           (result (if eof-error-p
-                                       (,in-fun in ,@args)
-                                       (,in-fun in nil in))))
-                      (cond
-                        ((eql result in) eof-value)
-                        (t (,out-fun result out) result)))))))
+                (let* ((unread-stuff-p (echo-stream-unread-stuff stream))
+                       (in (echo-stream-input-stream stream))
+                       (out (echo-stream-output-stream stream))
+                       (result (if eof-error-p
+                                   (,in-fun in ,@args)
+                                   (,in-fun in nil in))))
+                  (setf (echo-stream-unread-stuff stream) nil)
+                  (cond
+                    ((eql result in) eof-value)
+                    ;; If unread-stuff was true, the character read
+                    ;; from the input stream was previously echoed.
+                    (t (unless unread-stuff-p (,out-fun result out)) result))))))
   (in-fun echo-in read-char write-char eof-error-p eof-value)
   (in-fun echo-bin read-byte write-byte eof-error-p eof-value))
 
 (defun echo-n-bin (stream buffer start numbytes eof-error-p)
-  (let ((new-start start)
-        (read 0))
-    (loop
-     (let ((thing (pop (echo-stream-unread-stuff stream))))
-       (cond
-         (thing
-          (setf (aref buffer new-start) thing)
-          (incf new-start)
-          (incf read)
-          (when (= read numbytes)
-            (return-from echo-n-bin numbytes)))
-         (t (return nil)))))
-    (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
-                                    new-start (- numbytes read) nil)))
-      (cond
-        ((not eof-error-p)
-         (write-sequence buffer (echo-stream-output-stream stream)
-                         :start new-start :end (+ new-start bytes-read))
-         (+ bytes-read read))
-        ((> numbytes (+ read bytes-read))
-         (write-sequence buffer (echo-stream-output-stream stream)
-                         :start new-start :end (+ new-start bytes-read))
-         (error 'end-of-file :stream stream))
-        (t
-         (write-sequence buffer (echo-stream-output-stream stream)
-                         :start new-start :end (+ new-start bytes-read))
-         (aver (= numbytes (+ new-start bytes-read)))
-         numbytes)))))
+  (let ((bytes-read 0))
+    ;; Note: before ca 1.0.27.18, the logic for handling unread
+    ;; characters never could have worked, so probably nobody has ever
+    ;; tried doing bivalent block I/O through an echo stream; this may
+    ;; not work either.
+    (when (echo-stream-unread-stuff stream)
+      (let* ((char (read-char stream))
+             (octets (octets-to-string
+                      (string char)
+                      :external-format
+                      (stream-external-format
+                       (echo-stream-input-stream stream))))
+             (octet-count (length octets))
+             (blt-count (min octet-count numbytes)))
+        (replace buffer octets :start1 start :end1 (+ start blt-count))
+        (incf start blt-count)
+        (decf numbytes blt-count)))
+    (incf bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
+                                   start numbytes nil))
+    (cond
+      ((not eof-error-p)
+       (write-sequence buffer (echo-stream-output-stream stream)
+                       :start start :end (+ start bytes-read))
+       bytes-read)
+      ((> numbytes bytes-read)
+       (write-sequence buffer (echo-stream-output-stream stream)
+                       :start start :end (+ start bytes-read))
+       (error 'end-of-file :stream stream))
+      (t
+       (write-sequence buffer (echo-stream-output-stream stream)
+                       :start start :end (+ start bytes-read))
+       (aver (= numbytes (+ start bytes-read)))
+       numbytes))))
 \f
 ;;;; STRING-INPUT-STREAM stuff
 
@@ -1597,7 +1604,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
                 (setf workspace new-workspace
                       offset-current current)
                 (set-array-header buffer workspace new-length
-                                  current+1 0 new-length nil))
+                                  current+1 0 new-length nil nil))
               (setf (fill-pointer buffer) current+1))
           (setf (char workspace offset-current) character))))
     current+1))
@@ -1631,7 +1638,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
                       offset-current current
                       offset-dst-end dst-end)
                 (set-array-header buffer workspace new-length
-                                  dst-end 0 new-length nil))
+                                  dst-end 0 new-length nil nil))
               (setf (fill-pointer buffer) dst-end))
           (replace workspace string
                    :start1 offset-current :start2 start :end2 end)))