1.0.21.14: fix CHECK-FASL-HEADER buglet

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

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 223a9a1..eb40f58 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -53,44 +53,36 @@
          :format-arguments (list stream)))
 (defun closed-flame (stream &rest ignore)
   (declare (ignore ignore))
          :format-arguments (list stream)))
 (defun closed-flame (stream &rest ignore)
   (declare (ignore ignore))

-  (error "~S is closed." stream))
+  (error 'closed-stream-error :stream stream))

 (defun no-op-placeholder (&rest ignore)
   (declare (ignore ignore)))
 \f
 ;;; stream manipulation functions
 
 (defun no-op-placeholder (&rest ignore)
   (declare (ignore ignore)))
 \f
 ;;; stream manipulation functions
 

-(declaim (inline ansi-stream-input-stream-p))

 (defun ansi-stream-input-stream-p (stream)
   (declare (type ansi-stream stream))
 (defun ansi-stream-input-stream-p (stream)
   (declare (type ansi-stream stream))

-
-  (when (synonym-stream-p stream)
-    (setf stream
-          (symbol-value (synonym-stream-symbol stream))))
-
-  (and (not (eq (ansi-stream-in stream) #'closed-flame))
+  (if (synonym-stream-p stream)
+      (input-stream-p (symbol-value (synonym-stream-symbol stream)))
+      (and (not (eq (ansi-stream-in stream) #'closed-flame))

        ;;; KLUDGE: It's probably not good to have EQ tests on function
        ;;; values like this. What if someone's redefined the function?
        ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
        ;;; VALID-FOR-OUTPUT flags? -- WHN 19990902
        ;;; KLUDGE: It's probably not good to have EQ tests on function
        ;;; values like this. What if someone's redefined the function?
        ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
        ;;; VALID-FOR-OUTPUT flags? -- WHN 19990902

-       (or (not (eq (ansi-stream-in stream) #'ill-in))
-           (not (eq (ansi-stream-bin stream) #'ill-bin)))))
+           (or (not (eq (ansi-stream-in stream) #'ill-in))
+               (not (eq (ansi-stream-bin stream) #'ill-bin))))))

 
 (defun input-stream-p (stream)
   (declare (type stream stream))
   (and (ansi-stream-p stream)
        (ansi-stream-input-stream-p stream)))
 
 
 (defun input-stream-p (stream)
   (declare (type stream stream))
   (and (ansi-stream-p stream)
        (ansi-stream-input-stream-p stream)))
 

-(declaim (inline ansi-stream-output-stream-p))

 (defun ansi-stream-output-stream-p (stream)
   (declare (type ansi-stream stream))
 (defun ansi-stream-output-stream-p (stream)
   (declare (type ansi-stream stream))

-
-  (when (synonym-stream-p stream)
-    (setf stream (symbol-value
-                  (synonym-stream-symbol stream))))
-
-  (and (not (eq (ansi-stream-in stream) #'closed-flame))
-       (or (not (eq (ansi-stream-out stream) #'ill-out))
-           (not (eq (ansi-stream-bout stream) #'ill-bout)))))
+  (if (synonym-stream-p stream)
+      (output-stream-p (symbol-value (synonym-stream-symbol stream)))
+      (and (not (eq (ansi-stream-in stream) #'closed-flame))
+           (or (not (eq (ansi-stream-out stream) #'ill-out))
+               (not (eq (ansi-stream-bout stream) #'ill-bout))))))

 
 (defun output-stream-p (stream)
   (declare (type stream stream))
 
 (defun output-stream-p (stream)
   (declare (type stream stream))

@@ -136,13 +128,17 @@
   (setf (ansi-stream-in stream) #'closed-flame)
   (setf (ansi-stream-bin stream) #'closed-flame)
   (setf (ansi-stream-n-bin stream) #'closed-flame)
   (setf (ansi-stream-in stream) #'closed-flame)
   (setf (ansi-stream-bin stream) #'closed-flame)
   (setf (ansi-stream-n-bin stream) #'closed-flame)

-  (setf (ansi-stream-in stream) #'closed-flame)

   (setf (ansi-stream-out stream) #'closed-flame)
   (setf (ansi-stream-bout stream) #'closed-flame)
   (setf (ansi-stream-sout stream) #'closed-flame)
   (setf (ansi-stream-misc stream) #'closed-flame))
 \f
 ;;;; file position and file length
   (setf (ansi-stream-out stream) #'closed-flame)
   (setf (ansi-stream-bout stream) #'closed-flame)
   (setf (ansi-stream-sout stream) #'closed-flame)
   (setf (ansi-stream-misc stream) #'closed-flame))
 \f
 ;;;; 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))))

 
 ;;; Call the MISC method with the :FILE-POSITION operation.
 #!-sb-fluid (declaim (inline ansi-stream-file-position))
 
 ;;; Call the MISC method with the :FILE-POSITION operation.
 #!-sb-fluid (declaim (inline ansi-stream-file-position))

@@ -164,19 +160,20 @@
             (- +ansi-stream-in-buffer-length+
                (ansi-stream-in-index stream)))
          #!+sb-unicode
             (- +ansi-stream-in-buffer-length+
                (ansi-stream-in-index stream)))
          #!+sb-unicode

-         (let* ((external-format (stream-external-format stream))
-                (ef-entry (find-external-format external-format))
-                (variable-width-p (variable-width-external-format-p ef-entry))
-                (char-len (bytes-for-char-fun ef-entry)))
+         (let ((char-size (if (fd-stream-p stream)
+                              (fd-stream-char-size stream)
+                              (external-format-char-size (stream-external-format stream)))))

            (- res
            (- res

-              (if variable-width-p
-                  (loop with buffer = (ansi-stream-cin-buffer stream)
-                        with start = (ansi-stream-in-index stream)
-                        for i from start below +ansi-stream-in-buffer-length+
-                        sum (funcall char-len (aref buffer i)))
-                  (* (funcall char-len #\x)  ; arbitrary argument
-                     (- +ansi-stream-in-buffer-length+
-                        (ansi-stream-in-index stream)))))))))))
+              (etypecase char-size
+                (function
+                 (loop with buffer = (ansi-stream-cin-buffer stream)
+                       with start = (ansi-stream-in-index stream)
+                       for i from start below +ansi-stream-in-buffer-length+
+                       sum (funcall char-size (aref buffer i))))
+                (fixnum
+                 (* char-size
+                    (- +ansi-stream-in-buffer-length+
+                       (ansi-stream-in-index stream))))))))))))

 
 (defun file-position (stream &optional position)
   (if (ansi-stream-p stream)
 
 (defun file-position (stream &optional position)
   (if (ansi-stream-p stream)

@@ -271,7 +268,7 @@
                               :start2 %frc-index% :end2 pos)
                      (setf %frc-index% (1+ pos)))
                    (done-with-fast-read-char)
                               :start2 %frc-index% :end2 pos)
                      (setf %frc-index% (1+ pos)))
                    (done-with-fast-read-char)

-                   (return-from ansi-stream-read-line-from-frc-buffer res)))
+                   (return-from ansi-stream-read-line-from-frc-buffer (values res (null pos)))))

                (add-chunk ()
                  (let* ((end (length %frc-buffer%))
                         (len (- end %frc-index%))
                (add-chunk ()
                  (let* ((end (length %frc-buffer%))
                         (len (- end %frc-index%))

@@ -281,7 +278,8 @@
                    (incf chunks-total-length len)
                    (when (refill-buffer)
                      (make-and-return-result-string nil)))))
                    (incf chunks-total-length len)
                    (when (refill-buffer)
                      (make-and-return-result-string nil)))))

-        (declare (inline make-and-return-result-string))
+        (declare (inline make-and-return-result-string
+                         refill-buffer))

         (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
                    (refill-buffer))
           ;; EOF had been reached before we read anything
         (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
                    (refill-buffer))
           ;; EOF had been reached before we read anything

@@ -1534,14 +1532,20 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
     (flet ((replace-all (fun)
              (let ((start 0))
                (declare (index start))
     (flet ((replace-all (fun)
              (let ((start 0))
                (declare (index start))

-               (dolist (buffer (nreverse prev))
+               (setf prev (nreverse prev))
+               (dolist (buffer prev)

                  (funcall fun buffer start)
                  (incf start (length buffer)))
                (funcall fun this start)
                (incf start (length this))
                (dolist (buffer next)
                  (funcall fun buffer start)
                  (funcall fun buffer start)
                  (incf start (length buffer)))
                (funcall fun this start)
                (incf start (length this))
                (dolist (buffer next)
                  (funcall fun buffer start)

-                 (incf start (length buffer))))))
+                 (incf start (length buffer)))
+               ;; Hack: erase the pointers to strings, to make it less
+               ;; likely that the conservative GC will accidentally
+               ;; retain the buffers.
+               (fill prev nil)
+               (fill next nil))))

       (macrolet ((frob (type)
                    `(replace-all (lambda (buffer from)
                                    (declare (type ,type result)
       (macrolet ((frob (type)
                    `(replace-all (lambda (buffer from)
                                    (declare (type ,type result)

@@ -2108,11 +2112,13 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
                               :start2 %frc-index%
                               :end2 (+ %frc-index% len)))
                    (incf read len)
                               :start2 %frc-index%
                               :end2 (+ %frc-index% len)))
                    (incf read len)

+                   (incf %frc-index% len)

                    (when (or (eql needed read)
                              (refill-buffer))
                      (done-with-fast-read-char)
                      (return-from ansi-stream-read-string-from-frc-buffer
                        read)))))
                    (when (or (eql needed read)
                              (refill-buffer))
                      (done-with-fast-read-char)
                      (return-from ansi-stream-read-string-from-frc-buffer
                        read)))))

+        (declare (inline refill-buffer))

         (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
                    (refill-buffer))
           ;; EOF had been reached before we read anything
         (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
                    (refill-buffer))
           ;; EOF had been reached before we read anything