(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))
(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)))
(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))
(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)))
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
(in-fun synonym-bin read-byte eof-error-p eof-value)
(in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p))
-;;; We have to special-case the operations which could look at stuff in
-;;; the in-buffer.
(defun synonym-misc (stream operation &optional arg1 arg2)
(declare (optimize (safety 1)))
(let ((syn (symbol-value (synonym-stream-symbol stream))))
(if (lisp-stream-p syn)
- (case operation
+ ;; We have to special-case some operations which interact with
+ ;; the in-buffer of the wrapped stream, since just calling
+ ;; LISP-STREAM-MISC on them
+ (case operation
(:listen (or (/= (the fixnum (lisp-stream-in-index syn))
+in-buffer-length+)
(funcall (lisp-stream-misc syn) syn :listen)))
+ (:clear-input (clear-input syn))
+ (:unread (unread-char arg1 syn))
(t
(funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
(stream-misc-dispatch syn operation arg1 arg2))))
(if out-lisp-stream-p
(funcall (lisp-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))
- ((:clear-input :unread)
- (if in-lisp-stream-p
- (funcall (lisp-stream-misc in) in operation arg1 arg2)
- (stream-misc-dispatch in operation arg1 arg2)))
+ (:clear-input (clear-input in))
+ (:unread (unread-char arg1 in))
(:element-type
(let ((in-type (stream-element-type in))
(out-type (stream-element-type out)))
(t
;; Nothing is available yet.
(return nil))))))
- (:close
+ (:clear-input (clear-input current))
+ (:unread (unread-char arg1 current))
+ (:close
(set-closed-flame stream))
(t
(if (lisp-stream-p current)
(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
(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)
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)
projects / sbcl.git / blobdiff