(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)
(defun %write-string (string stream start end)
(declare (type string string))
- (declare (type streamlike stream))
+ (declare (type stream-designator stream))
(declare (type index start end))
(let ((stream (out-synonym-of stream)))
(cond ((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)))
(&rest streams &aux (current streams)))
(:copier nil))
;; The car of this is the substream we are reading from now.
- current
- ;; This is a list of all the substreams there ever were. We need to
- ;; remember them so that we can close them.
- ;;
- ;; FIXME: ANSI says this is supposed to be the list of streams that
- ;; we still have to read from. So either this needs to become a
- ;; private member %STREAM (with CONCATENATED-STREAM-STREAMS a wrapper
- ;; around it which discards closed files from the head of the list)
- ;; or we need to update it as we run out of files.
- (streams nil :type list :read-only t))
+ (streams nil :type list))
(def!method print-object ((x concatenated-stream) stream)
(print-unreadable-object (x stream :type t :identity t)
(format stream
"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))))
(macrolet ((in-fun (name fun)
`(defun ,name (stream eof-error-p eof-value)
- (do ((current (concatenated-stream-current stream)
- (cdr current)))
- ((null current)
+ (do ((streams (concatenated-stream-streams stream)
+ (cdr streams)))
+ ((null streams)
(eof-or-lose stream eof-error-p eof-value))
- (let* ((stream (car current))
+ (let* ((stream (car streams))
(result (,fun stream nil nil)))
(when result (return result)))
- (pop (concatenated-stream-current stream))))))
+ (pop (concatenated-stream-streams stream))))))
(in-fun concatenated-in read-char)
(in-fun concatenated-bin read-byte))
(defun concatenated-n-bin (stream buffer start numbytes eof-errorp)
- (do ((current (concatenated-stream-current stream) (cdr current))
+ (do ((streams (concatenated-stream-streams stream) (cdr streams))
(current-start start)
(remaining-bytes numbytes))
((null current)
(incf current-start bytes-read)
(decf remaining-bytes bytes-read)
(when (zerop remaining-bytes) (return numbytes)))
- (setf (concatenated-stream-current stream) (cdr current))))
+ (setf (concatenated-stream-streams stream) (cdr streams))))
(defun concatenated-misc (stream operation &optional arg1 arg2)
- (let ((left (concatenated-stream-current stream)))
+ (let ((left (concatenated-stream-streams stream)))
(when left
(let* ((current (car left)))
(case operation
:listen)
(stream-misc-dispatch current :listen))))
(cond ((eq stuff :eof)
- ;; Advance CURRENT, and try again.
- (pop (concatenated-stream-current stream))
+ ;; Advance STREAMS, and try again.
+ (pop (concatenated-stream-streams stream))
(setf current
- (car (concatenated-stream-current stream)))
+ (car (concatenated-stream-streams stream)))
(unless current
;; No further streams. EOF.
(return :eof)))
"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)))
(or (pop (echo-stream-unread-stuff stream))
(let* ((in (echo-stream-input-stream stream))
(out (echo-stream-output-stream stream))
- (result (,in-fun in ,@args)))
- (,out-fun result out)
- result)))))
+ (result (if eof-error-p
+ (,in-fun in ,@args)
+ (,in-fun in nil in))))
+ (cond
+ ((eql result in) eof-value)
+ (t (,out-fun result out) 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))
\f
(declare (type string string)
(type index start)
(type (or index null) end))
- (let ((end (%check-vector-sequence-bounds string start end)))
+ (let* ((string (coerce string '(simple-array character (*))))
+ (end (%check-vector-sequence-bounds string start end)))
(with-array-data ((string string) (start start) (end end))
(internal-make-string-input-stream
string ;; now simple
(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