(in-package "SB!IMPL")
-(deftype string-stream ()
- '(or string-input-stream string-output-stream
- fill-pointer-output-stream))
-
;;;; standard streams
;;; The initialization of these streams is performed by
(stream-unread-char stream character)))
nil)
+
+;;; In the interest of ``once and only once'' this macro contains the
+;;; framework necessary to implement a peek-char function, which has
+;;; two special-cases (one for gray streams and one for echo streams)
+;;; in addition to the normal case.
+;;;
+;;; All arguments are forms which will be used for a specific purpose
+;;; PEEK-TYPE - the current peek-type as defined by ANSI CL
+;;; EOF-VALUE - the eof-value argument to peek-char
+;;; CHAR-VAR - the variable which will be used to store the current character
+;;; READ-FORM - the form which will be used to read a character
+;;; UNREAD-FORM - ditto for unread-char
+;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
+;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
+;;; (this will default to CHAR-VAR)
+(defmacro generalized-peeking-mechanism (peek-type eof-value char-var read-form unread-form &optional (skipped-char-form nil) (eof-detected-form nil))
+ `(let ((,char-var ,read-form))
+ (cond ((eql ,char-var ,eof-value)
+ ,(if eof-detected-form
+ eof-detected-form
+ char-var))
+ ((characterp ,peek-type)
+ (do ((,char-var ,char-var ,read-form))
+ ((or (eql ,char-var ,eof-value)
+ (char= ,char-var ,peek-type))
+ (cond ((eql ,char-var ,eof-value)
+ ,(if eof-detected-form
+ eof-detected-form
+ char-var))
+ (t ,unread-form
+ ,char-var)))
+ ,skipped-char-form))
+ ((eql ,peek-type t)
+ (do ((,char-var ,char-var ,read-form))
+ ((or (eql ,char-var ,eof-value)
+ (not (whitespace-char-p ,char-var)))
+ (cond ((eql ,char-var ,eof-value)
+ ,(if eof-detected-form
+ eof-detected-form
+ char-var))
+ (t ,unread-form
+ ,char-var)))
+ ,skipped-char-form))
+ ((null ,peek-type)
+ ,unread-form
+ ,char-var)
+ (t
+ (bug "Impossible case reached in PEEK-CHAR")))))
+
(defun peek-char (&optional (peek-type nil)
(stream *standard-input*)
(eof-error-p t)
:format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"
:format-arguments (list peek-type '(or character boolean))))
(let ((stream (in-synonym-of stream)))
- (if (ansi-stream-p stream)
- (let ((char (read-char stream eof-error-p eof-value)))
- (cond ((eq char eof-value) char)
- ((characterp peek-type)
- (do ((char char (read-char stream eof-error-p eof-value)))
- ((or (eq char eof-value) (char= char peek-type))
- (unless (eq char eof-value)
- (unread-char char stream))
- char)))
- ((eq peek-type t)
- (do ((char char (read-char stream eof-error-p eof-value)))
- ((or (eq char eof-value) (not (whitespace-char-p char)))
- (unless (eq char eof-value)
- (unread-char char stream))
- char)))
- ((null peek-type)
- (unread-char char stream)
- char)
- (t
- (bug "impossible case"))))
- ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
- (cond ((characterp peek-type)
- (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))
- (t
- (stream-unread-char stream char)
- char)))))
- ((eq peek-type t)
- (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)))))
- ((null peek-type)
- (let ((char (stream-peek-char stream)))
- (if (eq char :eof)
- (eof-or-lose stream eof-error-p eof-value)
- char)))
- (t
- (bug "impossible case"))))))
+ (cond ((typep stream 'echo-stream)
+ (echo-misc stream
+ :peek-char
+ peek-type
+ (list eof-error-p eof-value)))
+ ((ansi-stream-p stream)
+ (generalized-peeking-mechanism
+ peek-type eof-value char
+ (read-char stream eof-error-p eof-value)
+ (unread-char char stream)))
+ (t
+ ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
+ (generalized-peeking-mechanism
+ peek-type :eof char
+ (if (null peek-type)
+ (stream-peek-char stream)
+ (stream-read-char stream))
+ (if (null peek-type)
+ ()
+ (stream-unread-char stream char))
+ ()
+ (eof-or-lose stream eof-error-p eof-value))))))
(defun listen (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
in-type `(and ,in-type ,out-type))))
(:close
(set-closed-flame stream))
+ (:peek-char
+ ;; For the special case of peeking into an echo-stream
+ ;; arg1 is PEEK-TYPE, arg2 is (EOF-ERROR-P EOF-VALUE)
+ ;; returns peeked-char, eof-value, or errors end-of-file
+ ;;
+ ;; Note: This code could be moved into PEEK-CHAR if desired.
+ ;; I am unsure whether this belongs with echo-streams because it is
+ ;; echo-stream specific, or PEEK-CHAR because it is peeking code.
+ ;; -- mrd 2002-11-18
+ ;;
+ ;; UNREAD-CHAR-P indicates whether the current character was one
+ ;; that was previously unread. In that case, we need to ensure that
+ ;; the semantics for UNREAD-CHAR are held; the character should
+ ;; not be echoed again.
+ (let ((unread-char-p nil))
+ (flet ((outfn (c)
+ (unless unread-char-p
+ (if (ansi-stream-p out)
+ (funcall (ansi-stream-out out) out c)
+ ;; gray-stream
+ (stream-write-char out c))))
+ (infn ()
+ ;; Obtain input from unread buffer or input stream,
+ ;; and set the flag appropriately.
+ (cond ((not (null (echo-stream-unread-stuff stream)))
+ (setf unread-char-p t)
+ (pop (echo-stream-unread-stuff stream)))
+ (t
+ (setf unread-char-p nil)
+ (read-char in (first arg2) (second arg2))))))
+ (generalized-peeking-mechanism
+ arg1 (second arg2) char
+ (infn)
+ (unread-char char in)
+ (outfn char)))))
(t
(or (if (ansi-stream-p in)
(funcall (ansi-stream-misc in) in operation arg1 arg2)
(if (ansi-stream-p out)
(funcall (ansi-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))))))
+\f
+;;;; base STRING-STREAM stuff
+(defstruct (string-stream
+ (:include ansi-stream)
+ (:constructor nil)
+ (:copier nil))
+ (string nil :type string))
\f
-;;;; string input streams
+;;;; STRING-INPUT-STREAM stuff
(defstruct (string-input-stream
- (:include ansi-stream
+ (:include string-stream
(in #'string-inch)
(bin #'string-binch)
(n-bin #'string-stream-read-n-bytes)
- (misc #'string-in-misc))
+ (misc #'string-in-misc)
+ (string nil :type simple-string))
(:constructor internal-make-string-input-stream
(string current end))
(:copier nil))
- (string nil :type simple-string)
(current nil :type index)
(end nil :type index))
(internal-make-string-input-stream (coerce string 'simple-string)
start end))
\f
-;;;; string output streams
+;;;; STRING-OUTPUT-STREAM stuff
(defstruct (string-output-stream
- (:include ansi-stream
+ (:include string-stream
(out #'string-ouch)
(sout #'string-sout)
- (misc #'string-out-misc))
+ (misc #'string-out-misc)
+ ;; The string we throw stuff in.
+ (string (make-string 40) :type simple-string))
(:constructor make-string-output-stream ())
(:copier nil))
- ;; The string we throw stuff in.
- (string (make-string 40) :type simple-string)
;; Index of the next location to use.
(index 0 :type fixnum))
(satisfies array-has-fill-pointer-p)))
(defstruct (fill-pointer-output-stream
- (:include ansi-stream
+ (:include string-stream
(out #'fill-pointer-ouch)
(sout #'fill-pointer-sout)
- (misc #'fill-pointer-misc))
+ (misc #'fill-pointer-misc)
+ ;; a string with a fill pointer where we stuff
+ ;; the stuff we write
+ (string (error "missing argument")
+ :type string-with-fill-pointer
+ :read-only t))
(:constructor make-fill-pointer-output-stream (string))
- (:copier nil))
- ;; a string with a fill pointer where we stuff the stuff we write
- (string (error "missing argument")
- :type string-with-fill-pointer
- :read-only t))
+ (:copier nil)))
(defun fill-pointer-ouch (stream character)
(let* ((buffer (fill-pointer-output-stream-string stream))
projects / sbcl.git / blobdiff