(defun ansi-stream-input-stream-p (stream)
(declare (type ansi-stream stream))
- #!+high-security
(when (synonym-stream-p stream)
(setf stream
(symbol-value (synonym-stream-symbol stream))))
(defun ansi-stream-output-stream-p (stream)
(declare (type ansi-stream stream))
- #!+high-security
(when (synonym-stream-p stream)
(setf stream (symbol-value
(synonym-stream-symbol stream))))
(declaim (inline ansi-stream-open-stream-p))
(defun ansi-stream-open-stream-p (stream)
(declare (type ansi-stream stream))
+ ;; CLHS 22.1.4 lets us not worry about synonym streams here.
(not (eq (ansi-stream-in stream) #'closed-flame)))
(defun open-stream-p (stream)
(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)
- eof-value
- recursive-p)
- (declare (ignore recursive-p))
- (let ((stream (in-synonym-of stream)))
- (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)))
(if (ansi-stream-p stream)
(defun make-broadcast-stream (&rest streams)
(dolist (stream streams)
- (unless (or (and (synonym-stream-p stream)
- (output-stream-p (symbol-value
- (synonym-stream-symbol stream))))
- (output-stream-p stream))
+ (unless (output-stream-p stream)
(error 'type-error
:datum stream
:expected-type '(satisfies output-stream-p))))
(defun broadcast-misc (stream operation &optional arg1 arg2)
(let ((streams (broadcast-stream-streams stream)))
(case operation
+ ;; FIXME: This may not be the best place to note this, but I
+ ;; think the :CHARPOS protocol needs revision. Firstly, I think
+ ;; this is the last place where a NULL return value was possible
+ ;; (before adjusting it to be 0), so a bunch of conditionals IF
+ ;; CHARPOS can be removed; secondly, it is my belief that
+ ;; FD-STREAMS, when running FILE-POSITION, do not update the
+ ;; CHARPOS, and consequently there will be much wrongness.
+ ;;
+ ;; FIXME: see also TWO-WAY-STREAM treatment of :CHARPOS -- why
+ ;; is it testing the :charpos of an input stream?
+ ;;
+ ;; -- CSR, 2004-02-04
(:charpos
- (dolist (stream streams)
+ (dolist (stream streams 0)
(let ((charpos (charpos stream)))
(if charpos (return charpos)))))
(:line-length
(let ((res (line-length stream)))
(when res (setq min (if min (min res min) res)))))))
(:element-type
+ #+nil ; old, arguably more logical, version
(let (res)
- (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
- (pushnew (stream-element-type stream) res :test #'equal))))
- (:close)
+ (dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
+ (pushnew (stream-element-type stream) res :test #'equal)))
+ ;; ANSI-specified version (under System Class BROADCAST-STREAM)
+ (let ((res t))
+ (do ((streams streams (cdr streams)))
+ ((null streams) res)
+ (when (null (cdr streams))
+ (setq res (stream-element-type (car streams)))))))
+ (:close
+ (set-closed-flame stream))
(t
(let ((res nil))
(dolist (stream streams res)
;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream
;; should be encapsulated in a function, and used here and most of
;; the other places that SYNONYM-STREAM-P appears.
- (unless (or (and (synonym-stream-p output-stream)
- (output-stream-p (symbol-value
- (synonym-stream-symbol output-stream))))
- (output-stream-p output-stream))
+ (unless (output-stream-p output-stream)
(error 'type-error
:datum output-stream
:expected-type '(satisfies output-stream-p)))
- (unless (or (and (synonym-stream-p input-stream)
- (input-stream-p (symbol-value
- (synonym-stream-symbol input-stream))))
- (input-stream-p input-stream))
+ (unless (input-stream-p input-stream)
(error 'type-error
:datum input-stream
:expected-type '(satisfies input-stream-p)))
"Return a stream which takes its input from each of the streams in turn,
going on to the next at EOF."
(dolist (stream streams)
- (unless (or (and (synonym-stream-p stream)
- (input-stream-p (symbol-value
- (synonym-stream-symbol stream))))
- (input-stream-p stream))
+ (unless (input-stream-p stream)
(error 'type-error
:datum stream
:expected-type '(satisfies input-stream-p))))
"Return a bidirectional stream which gets its input from INPUT-STREAM and
sends its output to OUTPUT-STREAM. In addition, all input is echoed to
the output stream."
- (unless (or (and (synonym-stream-p output-stream)
- (output-stream-p (symbol-value
- (synonym-stream-symbol output-stream))))
- (output-stream-p output-stream))
+ (unless (output-stream-p output-stream)
(error 'type-error
:datum output-stream
:expected-type '(satisfies output-stream-p)))
- (unless (or (and (synonym-stream-p input-stream)
- (input-stream-p (symbol-value
- (synonym-stream-symbol input-stream))))
- (input-stream-p input-stream))
+ (unless (input-stream-p input-stream)
(error 'type-error
:datum input-stream
:expected-type '(satisfies input-stream-p)))
result)))))
(in-fun echo-in read-char write-char eof-error-p eof-value)
(in-fun echo-bin read-byte write-byte eof-error-p eof-value))
-
-(defun echo-misc (stream operation &optional arg1 arg2)
- (let* ((in (two-way-stream-input-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)))
- (: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))))
- (: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)
- (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)))))))
\f
;;;; base STRING-STREAM stuff
(defun case-frob-misc (stream op &optional arg1 arg2)
(declare (type case-frob-stream stream))
(case op
- (:close)
+ (:close
+ (set-closed-flame stream))
(t
(let ((target (case-frob-stream-target stream)))
(if (ansi-stream-p target)
projects / sbcl.git / blobdiff