;;;
;;; 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
+;;; EOF-RESULT - 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
+;;; EOF-VALUE - the result returned from READ-FORM when hitting eof
;;; 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)
-(eval-when (:compile-toplevel :execute)
- (sb!xc: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 (whitespacep ,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"))))))
+;;; (this will default to EOF-RESULT)
+(sb!xc:defmacro generalized-peeking-mechanism
+ (peek-type eof-value char-var read-form read-eof unread-form
+ &optional (skipped-char-form nil) (eof-detected-form nil))
+ `(let ((,char-var ,read-form))
+ (cond ((eql ,char-var ,read-eof)
+ ,(if eof-detected-form
+ eof-detected-form
+ eof-value))
+ ((characterp ,peek-type)
+ (do ((,char-var ,char-var ,read-form))
+ ((or (eql ,char-var ,read-eof)
+ (char= ,char-var ,peek-type))
+ (cond ((eql ,char-var ,read-eof)
+ ,(if eof-detected-form
+ eof-detected-form
+ eof-value))
+ (t ,unread-form
+ ,char-var)))
+ ,skipped-char-form))
+ ((eql ,peek-type t)
+ (do ((,char-var ,char-var ,read-form))
+ ((or (eql ,char-var ,read-eof)
+ (not (whitespace[2]p ,char-var)))
+ (cond ((eql ,char-var ,read-eof)
+ ,(if eof-detected-form
+ eof-detected-form
+ eof-value))
+ (t ,unread-form
+ ,char-var)))
+ ,skipped-char-form))
+ ((null ,peek-type)
+ ,unread-form
+ ,char-var)
+ (t
+ (bug "Impossible case reached in PEEK-CHAR")))))
;;; rudi (2004-08-09): There was an inline declaration for read-char,
;;; unread-char, read-byte, listen here that was removed because these
(t
(generalized-peeking-mechanism
peek-type eof-value char
- (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
+ (ansi-stream-read-char stream eof-error-p :eof recursive-p)
+ :eof
(ansi-stream-unread-char char stream)))))
(defun peek-char (&optional (peek-type nil)
- (stream *standard-input*)
- (eof-error-p t)
- eof-value
- recursive-p)
+ (stream *standard-input*)
+ (eof-error-p t)
+ eof-value
+ recursive-p)
(the (or character boolean) peek-type)
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
(if (null peek-type)
(stream-peek-char stream)
(stream-read-char stream))
+ :eof
(if (null peek-type)
()
(stream-unread-char stream char))
(defun echo-misc (stream operation &optional arg1 arg2)
(let* ((in (two-way-stream-input-stream stream))
- (out (two-way-stream-output-stream stream)))
+ (out (two-way-stream-output-stream stream)))
(case operation
(:listen
- (or (not (null (echo-stream-unread-stuff stream)))
- (if (ansi-stream-p in)
- (or (/= (the fixnum (ansi-stream-in-index in))
- +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-misc in) in :listen))
- (stream-misc-dispatch in :listen))))
- (:unread (push arg1 (echo-stream-unread-stuff stream)))
+ (if (ansi-stream-p in)
+ (or (/= (the fixnum (ansi-stream-in-index in))
+ +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-misc in) in :listen))
+ (stream-misc-dispatch in :listen)))
+ (:unread (setf (echo-stream-unread-stuff stream) t)
+ (unread-char arg1 in))
(:element-type
(let ((in-type (stream-element-type in))
- (out-type (stream-element-type out)))
- (if (equal in-type out-type)
- in-type `(and ,in-type ,out-type))))
+ (out-type (stream-element-type out)))
+ (if (equal in-type out-type)
+ in-type `(and ,in-type ,out-type))))
(:close
(set-closed-flame stream))
(:peek-char
;; 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)))))
+ ;; UNREAD-P indicates whether the next character on IN 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-p nil)
+ ;; The first peek shouldn't touch the unread-stuff slot.
+ (initial-peek-p t))
+ (flet ((outfn (c)
+ (unless unread-p
+ (if (ansi-stream-p out)
+ (funcall (ansi-stream-out out) out c)
+ ;; gray-stream
+ (stream-write-char out c))))
+ (infn ()
+ (if initial-peek-p
+ (setf unread-p (echo-stream-unread-stuff stream))
+ (setf (echo-stream-unread-stuff stream) nil))
+ (setf initial-peek-p nil)
+ (read-char in (first arg2) :eof)))
+ (generalized-peeking-mechanism
+ arg1 (second arg2) char
+ (infn)
+ :eof
+ (unread-char char in)
+ (outfn char)))))
(t
(or (if (ansi-stream-p in)
- (funcall (ansi-stream-misc in) in operation arg1 arg2)
- (stream-misc-dispatch 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)))))))
+ (funcall (ansi-stream-misc in) in operation arg1 arg2)
+ (stream-misc-dispatch 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)))))))
projects / sbcl.git / blobdiff