X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=2bc1aa71a87620ca654c9b71c5fba5d45be2d86f;hb=54da325f13fb41669869aea688ae195426c0e231;hp=bd7086c0eed47b54673bc1a7a8622bbf1fad277d;hpb=e13eca4c5eaaffd3b16fb7f850b0df83a22c4f11;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index bd7086c..2bc1aa7 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -133,12 +133,9 @@
   (setf (ansi-stream-sout stream) #'closed-flame)
   (setf (ansi-stream-misc stream) #'closed-flame))
 
-;;;; file position and file length
+;;;; for file position and file length
 (defun external-format-char-size (external-format)
-  (let ((ef-entry (find-external-format external-format)))
-    (if (variable-width-external-format-p ef-entry)
-        (bytes-for-char-fun ef-entry)
-        (funcall (bytes-for-char-fun ef-entry) #\x))))
+  (ef-char-size (get-external-format external-format)))
 
 ;;; Call the MISC method with the :FILE-POSITION operation.
 #!-sb-fluid (declaim (inline ansi-stream-file-position))
@@ -146,7 +143,7 @@
   (declare (type stream stream))
   (declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
                  position))
-  ;; FIXME: It woud be good to comment on the stuff that is done here...
+  ;; FIXME: It would be good to comment on the stuff that is done here...
   ;; FIXME: This doesn't look interrupt safe.
   (cond
     (position
@@ -444,10 +441,8 @@
   ;; a-s-read-sequence and needs a lambda list that's congruent with
   ;; that of a-s-read-char
   (declare (ignore recursive-p))
-  (prepare-for-fast-read-byte stream
-    (prog1
-        (fast-read-byte eof-error-p eof-value t)
-      (done-with-fast-read-byte))))
+  (with-fast-read-byte (t stream eof-error-p eof-value)
+    (fast-read-byte)))
 
 (defun read-byte (stream &optional (eof-error-p t) eof-value)
   (if (ansi-stream-p stream)
@@ -548,22 +543,27 @@
            ;; An empty count does not necessarily mean that we reached
            ;; the EOF, it's also possible that it's e.g. due to a
            ;; invalid octet sequence in a multibyte stream. To handle
-           ;; the resyncing case correctly we need to call the
-           ;; single-character reading function and check whether an
-           ;; EOF was really reached. If not, we can just fill the
-           ;; buffer by one character, and hope that the next refill
-           ;; will not need to resync.
-           (let* ((value (funcall (ansi-stream-in stream) stream nil :eof))
-                  (index (1- +ansi-stream-in-buffer-length+)))
-             (case value
-               ((:eof)
-                ;; Mark buffer as empty.
+           ;; the resyncing case correctly we need to call the reading
+           ;; function and check whether an EOF was really reached. If
+           ;; not, we can just fill the buffer by one character, and
+           ;; hope that the next refill will not need to resync.
+           ;;
+           ;; KLUDGE: we can't use FD-STREAM functions (which are the
+           ;; only ones which will give us decoding errors) here,
+           ;; because this code is generic.  We can't call the N-BIN
+           ;; function, because near the end of a real file that can
+           ;; legitimately bounce us to the IN function.  So we have
+           ;; to call ANSI-STREAM-IN.
+           (let* ((index (1- +ansi-stream-in-buffer-length+))
+                  (value (funcall (ansi-stream-in stream) stream nil :eof)))
+             (cond
+               ((eql value :eof)
+                ;; definitely EOF now
                 (setf (ansi-stream-in-index stream)
                       +ansi-stream-in-buffer-length+)
-                ;; EOF. Redo the read, this time with the real eof parameters.
-                (values t (funcall (ansi-stream-in stream)
-                                   stream eof-error-p eof-value)))
-               (otherwise
+                (values t (eof-or-lose stream eof-error-p eof-value)))
+               ;; we resynced or were given something instead
+               (t
                 (setf (aref ibuf index) value)
                 (values nil (setf (ansi-stream-in-index stream) index))))))
           (t
@@ -687,7 +687,7 @@
 
 (defun clear-output (&optional (stream *standard-output*))
   (with-out-stream stream (ansi-stream-misc :clear-output)
-                   (stream-force-output))
+                   (stream-clear-output))
   nil)
 
 (defun write-byte (integer stream)
@@ -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 (string-to-octets
+                      (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))))
 
 ;;;; STRING-INPUT-STREAM stuff
 
@@ -1292,7 +1299,7 @@
   ;; end of the stream.
   (index-cache 0 :type index)
   ;; Requested element type
-  (element-type 'character))
+  (element-type 'character :type type-specifier))
 
 #!+sb-doc
 (setf (fdocumentation 'make-string-output-stream 'function)
@@ -1451,6 +1458,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
 
 (defun string-out-misc (stream operation &optional arg1 arg2)
   (declare (ignore arg2))
+  (declare (optimize speed))
   (case operation
     (:charpos
      ;; Keeping this first is a silly micro-optimization: FRESH-LINE
@@ -1460,8 +1468,10 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
             (buffer (string-output-stream-buffer stream))
             (prev (string-output-stream-prev stream))
             (base 0))
+        (declare (type (or null (simple-array character (*))) buffer))
       :next
-      (let ((pos (position #\newline buffer :from-end t :end pointer)))
+      (let ((pos (when buffer
+                   (position #\newline buffer :from-end t :end pointer))))
         (when (or pos (not buffer))
           ;; If newline is at index I, and pointer at index I+N, charpos
           ;; is N-1. If there is no newline, and pointer is at index N,
@@ -1557,11 +1567,16 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
 ;;; the CLM, but they are required for the implementation of
 ;;; WITH-OUTPUT-TO-STRING.
 
-;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL),
-;;; ideally without destroying all hope of efficiency.
+;;; FIXME: need to support (VECTOR NIL), ideally without destroying all hope
+;;; of efficiency.
+(declaim (inline vector-with-fill-pointer))
+(defun vector-with-fill-pointer-p (x)
+  (and (vectorp x)
+       (array-has-fill-pointer-p x)))
+
 (deftype string-with-fill-pointer ()
-  '(and (vector character)
-        (satisfies array-has-fill-pointer-p)))
+  `(and (or (vector character) (vector base-char))
+        (satisfies vector-with-fill-pointer-p)))
 
 (defstruct (fill-pointer-output-stream
             (:include ansi-stream
@@ -1579,53 +1594,63 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
          (current+1 (1+ current)))
     (declare (fixnum current))
     (with-array-data ((workspace buffer) (start) (end))
-      (declare (type (simple-array character (*)) workspace))
-      (let ((offset-current (+ start current)))
-        (declare (fixnum offset-current))
-        (if (= offset-current end)
-            (let* ((new-length (1+ (* current 2)))
-                   (new-workspace (make-string new-length)))
-              (declare (type (simple-array character (*)) new-workspace))
-              (replace new-workspace workspace
-                       :start2 start :end2 offset-current)
-              (setf workspace new-workspace
-                    offset-current current)
-              (set-array-header buffer workspace new-length
-                                current+1 0 new-length nil))
-            (setf (fill-pointer buffer) current+1))
-        (setf (schar workspace offset-current) character)))
+      (string-dispatch
+          ((simple-array character (*))
+           (simple-array base-char (*)))
+          workspace
+        (let ((offset-current (+ start current)))
+          (declare (fixnum offset-current))
+          (if (= offset-current end)
+              (let* ((new-length (1+ (* current 2)))
+                     (new-workspace
+                      (ecase (array-element-type workspace)
+                        (character (make-string new-length
+                                                :element-type 'character))
+                        (base-char (make-string new-length
+                                                :element-type 'base-char)))))
+                (replace new-workspace workspace :start2 start :end2 offset-current)
+                (setf workspace new-workspace
+                      offset-current current)
+                (set-array-header buffer workspace new-length
+                                  current+1 0 new-length nil nil))
+              (setf (fill-pointer buffer) current+1))
+          (setf (char workspace offset-current) character))))
     current+1))
 
 (defun fill-pointer-sout (stream string start end)
-  (declare (simple-string string) (fixnum start end))
-  (let* ((string (if (typep string '(simple-array character (*)))
-                     string
-                     (coerce string '(simple-array character (*)))))
-         (buffer (fill-pointer-output-stream-string stream))
-         (current (fill-pointer buffer))
-         (string-len (- end start))
-         (dst-end (+ string-len current)))
-    (declare (fixnum current dst-end string-len))
-    (with-array-data ((workspace buffer) (dst-start) (dst-length))
-      (declare (type (simple-array character (*)) workspace))
-      (let ((offset-dst-end (+ dst-start dst-end))
-            (offset-current (+ dst-start current)))
-        (declare (fixnum offset-dst-end offset-current))
-        (if (> offset-dst-end dst-length)
-            (let* ((new-length (+ (the fixnum (* current 2)) string-len))
-                   (new-workspace (make-string new-length)))
-              (declare (type (simple-array character (*)) new-workspace))
-              (replace new-workspace workspace
-                       :start2 dst-start :end2 offset-current)
-              (setf workspace new-workspace
-                    offset-current current
-                    offset-dst-end dst-end)
-              (set-array-header buffer workspace new-length
-                                dst-end 0 new-length nil))
-            (setf (fill-pointer buffer) dst-end))
-        (replace workspace string
-                 :start1 offset-current :start2 start :end2 end)))
-    dst-end))
+  (declare (fixnum start end))
+  (string-dispatch
+      ((simple-array character (*))
+       (simple-array base-char (*)))
+      string
+    (let* ((buffer (fill-pointer-output-stream-string stream))
+           (current (fill-pointer buffer))
+           (string-len (- end start))
+           (dst-end (+ string-len current)))
+      (declare (fixnum current dst-end string-len))
+      (with-array-data ((workspace buffer) (dst-start) (dst-length))
+        (let ((offset-dst-end (+ dst-start dst-end))
+              (offset-current (+ dst-start current)))
+          (declare (fixnum offset-dst-end offset-current))
+          (if (> offset-dst-end dst-length)
+              (let* ((new-length (+ (the fixnum (* current 2)) string-len))
+                     (new-workspace
+                      (ecase (array-element-type workspace)
+                        (character (make-string new-length
+                                                :element-type 'character))
+                        (base-char (make-string new-length
+                                                :element-type 'base-char)))))
+                (replace new-workspace workspace
+                         :start2 dst-start :end2 offset-current)
+                (setf workspace new-workspace
+                      offset-current current
+                      offset-dst-end dst-end)
+                (set-array-header buffer workspace new-length
+                                  dst-end 0 new-length nil nil))
+              (setf (fill-pointer buffer) dst-end))
+          (replace workspace string
+                   :start1 offset-current :start2 start :end2 end)))
+      dst-end)))
 
 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
   (declare (ignore arg2))
@@ -1659,8 +1684,9 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
            (if found
                (- end (the fixnum found))
                current)))))
-     (:element-type (array-element-type
-                     (fill-pointer-output-stream-string stream)))))
+     (:element-type
+      (array-element-type
+       (fill-pointer-output-stream-string stream)))))
 
 ;;;; case frobbing streams, used by FORMAT ~(...~)
 
@@ -2021,14 +2047,14 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
                              (refill-buffer))
                      (done-with-fast-read-char)
                      (return-from ansi-stream-read-string-from-frc-buffer
-                       read)))))
+                       (+ start read))))))
         (declare (inline refill-buffer))
         (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
                    (refill-buffer))
           ;; EOF had been reached before we read anything
           ;; at all. Return the EOF value or signal the error.
           (done-with-fast-read-char)
-          (return-from ansi-stream-read-string-from-frc-buffer 0))
+          (return-from ansi-stream-read-string-from-frc-buffer start))
         (loop (add-chunk))))))