X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=e9af49c1605d6625dba7ce902305127f07a7648c;hb=fbe6e22af842835f7c70309f4d48064ca3984ad0;hp=6422eccad7d6fdd963d9208263f460d97faddc48;hpb=2c6b90e36a7c0377cd79625eb6c94d580f98cb93;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 6422ecc..e9af49c 100644 --- 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 "~@" + :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 @@ -783,16 +797,19 @@ (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)))) @@ -878,10 +895,8 @@ (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))) @@ -1001,7 +1016,9 @@ (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) @@ -1281,12 +1298,8 @@ (let* ((new-length (* 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 @@ -1311,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) @@ -1328,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)