-(defun peek-char (&optional (peek-type nil)
- (stream *standard-input*)
- (eof-error-p t)
- 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 (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"))))))