0.6.12.49:

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

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 696e65e..39fe0f4 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -320,7 +320,7 @@
        (let ((index (1- (lisp-stream-in-index stream)))
              (buffer (lisp-stream-in-buffer stream)))
          (declare (fixnum index))
-         (when (minusp index) (error "Nothing to unread."))
+         (when (minusp index) (error "nothing to unread"))
          (cond (buffer
                 (setf (aref buffer index) (char-code character))
                 (setf (lisp-stream-in-index stream) index))
@@ -334,8 +334,20 @@
 (defun peek-char (&optional (peek-type nil)
                            (stream *standard-input*)
                            (eof-error-p t)
-                           eof-value recursive-p)
+                           eof-value
+                           recursive-p)
   (declare (ignore recursive-p))
+  ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but
+  ;; the compiler doesn't seem to be smart enough to go from there to
+  ;; imposing a type check. Figure out why (because PEEK-TYPE is an
+  ;; &OPTIONAL argument?) and fix it, and then this explicit type
+  ;; check can go away.
+  (unless (typep peek-type '(or character boolean))
+    (error 'simple-type-error
+          :datum peek-type
+          :expected-type '(or character boolean)
+          :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"
+          :format-arguments (list peek-type '(or character boolean))))
   (let ((stream (in-synonym-of stream)))
     (if (lisp-stream-p stream)
        (let ((char (read-char stream eof-error-p eof-value)))
@@ -352,12 +364,15 @@
                      (unless (eq char eof-value)
                        (unread-char char stream))
                      char)))
-               (t
+               ((null peek-type)
                 (unread-char char stream)
-                char)))
-       ;; must be Gray streams FUNDAMENTAL-STREAM
+                char)
+               (t
+                (error "internal error: impossible case"))))
+       ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
        (cond ((characterp peek-type)
-              (do ((char (stream-read-char stream) (stream-read-char stream)))
+              (do ((char (stream-read-char stream)
+                         (stream-read-char stream)))
                   ((or (eq char :eof) (char= char peek-type))
                    (cond ((eq char :eof)
                           (eof-or-lose stream eof-error-p eof-value))
@@ -365,18 +380,21 @@
                           (stream-unread-char stream char)
                           char)))))
              ((eq peek-type t)
-              (do ((char (stream-read-char stream) (stream-read-char stream)))
+              (do ((char (stream-read-char stream)
+                         (stream-read-char stream)))
                   ((or (eq char :eof) (not (whitespace-char-p char)))
                    (cond ((eq char :eof)
                           (eof-or-lose stream eof-error-p eof-value))
                          (t
                           (stream-unread-char stream char)
                           char)))))
-             (t
+             ((null peek-type)
               (let ((char (stream-peek-char stream)))
                 (if (eq char :eof)
                     (eof-or-lose stream eof-error-p eof-value)
-                    char)))))))
+                    char)))
+             (t
+              (error "internal error: impossible case"))))))
 
 (defun listen (&optional (stream *standard-input*))
   (let ((stream (in-synonym-of stream)))
@@ -455,17 +473,13 @@
               numbytes
               eof-error-p))
      ((<= numbytes num-buffered)
-      (%primitive sb!c:byte-blt
-                 in-buffer
-                 index
-                 buffer
-                 start
-                 (+ start numbytes))
+      (%byte-blt in-buffer index
+                buffer start (+ start numbytes))
       (setf (lisp-stream-in-index stream) (+ index numbytes))
       numbytes)
      (t
       (let ((end (+ start num-buffered)))
-       (%primitive sb!c:byte-blt in-buffer index buffer start end)
+       (%byte-blt in-buffer index buffer start end)
        (setf (lisp-stream-in-index stream) +in-buffer-length+)
        (+ (funcall (lisp-stream-n-bin stream)
                    stream
@@ -1281,15 +1295,11 @@
       (let ((offset-current (+ start current)))
        (declare (fixnum offset-current))
        (if (= offset-current end)
-           (let* ((new-length (* current 2))
+           (let* ((new-length (1+ (* current 2)))
                   (new-workspace (make-string new-length)))
              (declare (simple-string new-workspace))
-             (%primitive sb!c:byte-blt
-                         workspace
-                         start
-                         new-workspace
-                         0
-                         current)
+             (%byte-blt workspace start
+                        new-workspace 0 current)
              (setf workspace new-workspace)
              (setf offset-current current)
              (set-array-header buffer workspace new-length
@@ -1314,12 +1324,8 @@
            (let* ((new-length (+ (the fixnum (* current 2)) string-len))
                   (new-workspace (make-string new-length)))
              (declare (simple-string new-workspace))
-             (%primitive sb!c:byte-blt
-                         workspace
-                         dst-start
-                         new-workspace
-                         0
-                         current)
+             (%byte-blt workspace dst-start
+                        new-workspace 0 current)
              (setf workspace new-workspace)
              (setf offset-current current)
              (setf offset-dst-end dst-end)
@@ -1331,12 +1337,8 @@
                                new-length
                                nil))
            (setf (fill-pointer buffer) dst-end))
-       (%primitive sb!c:byte-blt
-                   string
-                   start
-                   workspace
-                   offset-current
-                   offset-dst-end)))
+       (%byte-blt string start
+                  workspace offset-current offset-dst-end)))
     dst-end))
 
 (defun fill-pointer-misc (stream operation &optional arg1 arg2)