(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)
;;;; file position and file length
;;; Call the MISC method with the :FILE-POSITION operation.
-(defun file-position (stream &optional position)
+#!-sb-fluid (declaim (inline ansi-stream-file-position))
+(defun ansi-stream-file-position (stream position)
(declare (type stream stream))
- (declare (type (or index (member nil :start :end)) position))
+ (declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
+ position))
(cond
- (position
- (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-misc stream) stream :file-position position))
- (t
- (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
- (when res
- (- res
- (- +ansi-stream-in-buffer-length+
- (ansi-stream-in-index stream))))))))
+ (position
+ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-misc stream) stream :file-position position))
+ (t
+ (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
+ (when res
+ (- res
+ (- +ansi-stream-in-buffer-length+
+ (ansi-stream-in-index stream))))))))
+
+
+(defun file-position (stream &optional position)
+ (ansi-stream-file-position stream position))
;;; This is a literal translation of the ANSI glossary entry "stream
;;; associated with a file".
\f
;;;; input functions
-(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
- recursive-p)
+#!-sb-fluid (declaim (inline ansi-stream-read-line))
+(defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p)
(declare (ignore recursive-p))
- (let ((stream (in-synonym-of stream)))
- (if (ansi-stream-p stream)
- (prepare-for-fast-read-char stream
+ (prepare-for-fast-read-char stream
(let ((res (make-string 80))
(len 80)
(index 0))
;; shouldn't do another READ-CHAR.
(t
(done-with-fast-read-char)
- (return (values (shrink-vector res index) t))))))))
+ (return (values (shrink-vector res index) t)))))))))
+
+(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
+ recursive-p)
+ (let ((stream (in-synonym-of stream)))
+ (if (ansi-stream-p stream)
+ (ansi-stream-read-line stream eof-error-p eof-value recursive-p)
;; must be Gray streams FUNDAMENTAL-STREAM
(multiple-value-bind (string eof) (stream-read-line stream)
(if (and eof (zerop (length string)))
(values (eof-or-lose stream eof-error-p eof-value) t)
(values string eof))))))
-;;; We proclaim them INLINE here, then proclaim them MAYBE-INLINE at EOF,
+;;; We proclaim them INLINE here, then proclaim them NOTINLINE later on,
;;; so, except in this file, they are not inline by default, but they can be.
#!-sb-fluid (declaim (inline read-char unread-char read-byte listen))
+#!-sb-fluid (declaim (inline ansi-stream-read-char))
+(defun ansi-stream-read-char (stream eof-error-p eof-value recursive-p)
+ (declare (ignore recursive-p))
+ (prepare-for-fast-read-char stream
+ (prog1
+ (fast-read-char eof-error-p eof-value)
+ (done-with-fast-read-char))))
+
(defun read-char (&optional (stream *standard-input*)
(eof-error-p t)
eof-value
recursive-p)
- (declare (ignore recursive-p))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (prepare-for-fast-read-char stream
- (prog1
- (fast-read-char eof-error-p eof-value)
- (done-with-fast-read-char)))
+ (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-char stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
char)))))
+#!-sb-fluid (declaim (inline ansi-stream-unread-char))
+(defun ansi-stream-unread-char (character stream)
+ (let ((index (1- (ansi-stream-in-index stream)))
+ (buffer (ansi-stream-cin-buffer stream)))
+ (declare (fixnum index))
+ (when (minusp index) (error "nothing to unread"))
+ (cond (buffer
+ (setf (aref buffer index) character)
+ (setf (ansi-stream-in-index stream) index))
+ (t
+ (funcall (ansi-stream-misc stream) stream
+ :unread character)))))
+
(defun unread-char (character &optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (let ((index (1- (ansi-stream-in-index stream)))
- (buffer (ansi-stream-in-buffer stream)))
- (declare (fixnum index))
- (when (minusp index) (error "nothing to unread"))
- (cond (buffer
- (setf (aref buffer index) (char-code character))
- (setf (ansi-stream-in-index stream) index))
- (t
- (funcall (ansi-stream-misc stream) stream
- :unread character))))
+ (ansi-stream-unread-char character stream)
;; must be Gray streams FUNDAMENTAL-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))))))
+#!-sb-fluid (declaim (inline ansi-stream-listen))
+(defun ansi-stream-listen (stream)
+ (or (/= (the fixnum (ansi-stream-in-index stream))
+ +ansi-stream-in-buffer-length+)
+ ;; Test for T explicitly since misc methods return :EOF sometimes.
+ (eq (funcall (ansi-stream-misc stream) stream :listen) t)))
(defun listen (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (or (/= (the fixnum (ansi-stream-in-index stream))
- +ansi-stream-in-buffer-length+)
- ;; Test for T explicitly since misc methods return :EOF sometimes.
- (eq (funcall (ansi-stream-misc stream) stream :listen) t))
+ (ansi-stream-listen stream)
;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
(stream-listen stream))))
+#!-sb-fluid (declaim (inline ansi-stream-read-char-no-hang))
+(defun ansi-stream-read-char-no-hang (stream eof-error-p eof-value recursive-p)
+ (if (funcall (ansi-stream-misc stream) stream :listen)
+ ;; On T or :EOF get READ-CHAR to do the work.
+ (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
+ nil))
+
(defun read-char-no-hang (&optional (stream *standard-input*)
(eof-error-p t)
eof-value
recursive-p)
- (declare (ignore recursive-p))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (if (funcall (ansi-stream-misc stream) stream :listen)
- ;; On T or :EOF get READ-CHAR to do the work.
- (read-char stream eof-error-p eof-value)
- nil)
+ (ansi-stream-read-char-no-hang stream eof-error-p eof-value
+ recursive-p)
;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-char-no-hang stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
char)))))
+#!-sb-fluid (declaim (inline ansi-stream-clear-input))
+(defun ansi-stream-clear-input (stream)
+ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-misc stream) stream :clear-input))
+
(defun clear-input (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
- (cond ((ansi-stream-p stream)
- (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-misc stream) stream :clear-input))
- (t
- (stream-clear-input stream))))
+ (if (ansi-stream-p stream)
+ (ansi-stream-clear-input stream)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (stream-clear-input stream)))
nil)
\f
-(declaim (maybe-inline read-byte))
+#!-sb-fluid (declaim (inline ansi-stream-read-byte))
+(defun ansi-stream-read-byte (stream eof-error-p eof-value recursive-p)
+ ;; Why the "recursive-p" parameter? a-s-r-b is funcall'ed from
+ ;; a-s-read-sequence and needs a lambda list that's congruent with
+ ;; that of a-s-read-char
+ (declare (ignore recursive-p))
+ (prepare-for-fast-read-byte stream
+ (prog1
+ (fast-read-byte eof-error-p eof-value t)
+ (done-with-fast-read-byte))))
+
(defun read-byte (stream &optional (eof-error-p t) eof-value)
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (prepare-for-fast-read-byte stream
- (prog1
- (fast-read-byte eof-error-p eof-value t)
- (done-with-fast-read-byte)))
+ (ansi-stream-read-byte stream eof-error-p eof-value nil)
;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-byte stream)))
(if (eq char :eof)
;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER,
;;; and hence must be an N-BIN method.
(defun fast-read-char-refill (stream eof-error-p eof-value)
- (let* ((ibuf (ansi-stream-in-buffer stream))
+ (let* ((ibuf (ansi-stream-cin-buffer stream))
(count (funcall (ansi-stream-n-bin stream)
stream
ibuf
sb!vm:n-word-bits))
(* count sb!vm:n-byte-bits)))
(setf (ansi-stream-in-index stream) (1+ start))
- (code-char (aref ibuf start))))))
+ (aref ibuf start)))))
;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
;;; leave room for unreading.
(with-out-stream stream (ansi-stream-out #\newline) (stream-terpri))
nil)
+#!-sb-fluid (declaim (inline ansi-stream-fresh-line))
+(defun ansi-stream-fresh-line (stream)
+ (when (/= (or (charpos stream) 1) 0)
+ (funcall (ansi-stream-out stream) stream #\newline)
+ t))
+
(defun fresh-line (&optional (stream *standard-output*))
(let ((stream (out-synonym-of stream)))
(if (ansi-stream-p stream)
- (when (/= (or (charpos stream) 1) 0)
- (funcall (ansi-stream-out stream) stream #\newline)
- t)
+ (ansi-stream-fresh-line stream)
;; must be Gray streams FUNDAMENTAL-STREAM
(stream-fresh-line stream))))
string start end))
string)
+#!-sb-fluid (declaim (inline ansi-stream-write-string))
+(defun ansi-stream-write-string (string stream start end)
+ (declare (type string string))
+ (declare (type ansi-stream stream))
+ (declare (type index start end))
+ (if (array-header-p string)
+ (with-array-data ((data string) (offset-start start)
+ (offset-end end))
+ (funcall (ansi-stream-sout stream)
+ stream data offset-start offset-end))
+ (funcall (ansi-stream-sout stream) stream string start end))
+ string)
+
(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)
- (if (array-header-p string)
- (with-array-data ((data string) (offset-start start)
- (offset-end end))
- (funcall (ansi-stream-sout stream)
- stream data offset-start offset-end))
- (funcall (ansi-stream-sout stream) stream string start end))
- string)
- (t ; must be Gray streams FUNDAMENTAL-STREAM
- (stream-write-string stream string start end)))))
+ (if(ansi-stream-p stream)
+ (ansi-stream-write-string string stream start end)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (stream-write-string stream string start end))))
+
+;;; A wrapper function for all those (MACROLET OUT-FUN) definitions,
+;;; which cannot deal with keyword arguments.
+(declaim (inline write-string-no-key))
+(defun write-string-no-key (string stream start end)
+ (write-string string stream :start start :end end))
(defun write-line (string &optional (stream *standard-output*)
&key (start 0) end)
(stream-write-byte integer))
integer)
\f
+
+;;; (These were inline throughout this file, but that's not appropriate
+;;; globally. And we must not inline them in the rest of this file if
+;;; dispatch to gray or simple streams is to work, since both redefine
+;;; these functions later.)
+(declaim (notinline read-char unread-char read-byte listen))
+
;;; This is called from ANSI-STREAM routines that encapsulate CLOS
;;; streams to handle the misc routines and dispatch to the
-;;; appropriate Gray stream functions.
+;;; appropriate SIMPLE- or FUNDAMENTAL-STREAM functions.
(defun stream-misc-dispatch (stream operation &optional arg1 arg2)
- (declare (type fundamental-stream stream)
- (ignore arg2))
- (case operation
+ (declare (type stream stream) (ignore arg2))
+ (ecase operation
(:listen
;; Return T if input available, :EOF for end-of-file, otherwise NIL.
- (let ((char (stream-read-char-no-hang stream)))
+ (let ((char (read-char-no-hang stream nil :eof)))
(when (characterp char)
- (stream-unread-char stream char))
+ (unread-char char stream))
char))
(:unread
- (stream-unread-char stream arg1))
+ (unread-char arg1 stream))
(:close
(close stream))
(:clear-input
- (stream-clear-input stream))
+ (clear-input stream))
(:force-output
- (stream-force-output stream))
+ (force-output stream))
(:finish-output
- (stream-finish-output stream))
+ (finish-output stream))
(:element-type
(stream-element-type stream))
(:interactive-p
(interactive-stream-p stream))
(:line-length
- (stream-line-length stream))
+ (line-length stream))
(:charpos
- (stream-line-column stream))
+ (charpos stream))
(:file-length
(file-length stream))
(:file-position
(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))))
(apply #'%make-broadcast-stream streams))
-(macrolet ((out-fun (fun method stream-method &rest args)
- `(defun ,fun (stream ,@args)
+(macrolet ((out-fun (name fun &rest args)
+ `(defun ,name (stream ,@args)
(dolist (stream (broadcast-stream-streams stream))
- (if (ansi-stream-p stream)
- (funcall (,method stream) stream ,@args)
- (,stream-method stream ,@args))))))
- (out-fun broadcast-out ansi-stream-out stream-write-char char)
- (out-fun broadcast-bout ansi-stream-bout stream-write-byte byte)
- (out-fun broadcast-sout ansi-stream-sout stream-write-string
- string start end))
+ (,fun ,(car args) stream ,@(cdr args))))))
+ (out-fun broadcast-out write-char char)
+ (out-fun broadcast-bout write-byte byte)
+ (out-fun broadcast-sout write-string-no-key string start end))
(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)))))))
+ (:file-position
+ (if arg1
+ (let ((res (or (eql arg1 :start) (eql arg1 0))))
+ (dolist (stream streams res)
+ (setq res (file-position stream arg1))))
+ (let ((res 0))
+ (dolist (stream streams res)
+ (setq res (file-position stream))))))
+ (:close
+ (set-closed-flame stream))
(t
(let ((res nil))
(dolist (stream streams res)
(print-unreadable-object (x stream :type t :identity t)
(format stream ":SYMBOL ~S" (synonym-stream-symbol x))))
-;;; The output simple output methods just call the corresponding method
-;;; in the synonymed stream.
-(macrolet ((out-fun (name slot stream-method &rest args)
+;;; The output simple output methods just call the corresponding
+;;; function on the synonymed stream.
+(macrolet ((out-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(declare (optimize (safety 1)))
(let ((syn (symbol-value (synonym-stream-symbol stream))))
- (if (ansi-stream-p syn)
- (funcall (,slot syn) syn ,@args)
- (,stream-method syn ,@args))))))
- (out-fun synonym-out ansi-stream-out stream-write-char ch)
- (out-fun synonym-bout ansi-stream-bout stream-write-byte n)
- (out-fun synonym-sout ansi-stream-sout stream-write-string string start end))
+ (,fun ,(car args) syn ,@(cdr args))))))
+ (out-fun synonym-out write-char ch)
+ (out-fun synonym-bout write-byte n)
+ (out-fun synonym-sout write-string-no-key string start end))
;;; For the input methods, we just call the corresponding function on the
;;; synonymed stream. These functions deal with getting input out of
;; 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)))
(funcall #'%make-two-way-stream input-stream output-stream))
-(macrolet ((out-fun (name slot stream-method &rest args)
+(macrolet ((out-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(let ((syn (two-way-stream-output-stream stream)))
- (if (ansi-stream-p syn)
- (funcall (,slot syn) syn ,@args)
- (,stream-method syn ,@args))))))
- (out-fun two-way-out ansi-stream-out stream-write-char ch)
- (out-fun two-way-bout ansi-stream-bout stream-write-byte n)
- (out-fun two-way-sout ansi-stream-sout stream-write-string string start end))
+ (,fun ,(car args) syn ,@(cdr args))))))
+ (out-fun two-way-out write-char ch)
+ (out-fun two-way-bout write-byte n)
+ (out-fun two-way-sout write-string-no-key string start end))
(macrolet ((in-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(bin #'concatenated-bin)
(n-bin #'concatenated-n-bin)
(misc #'concatenated-misc))
- (:constructor %make-concatenated-stream
- (&rest streams &aux (current streams)))
+ (:constructor %make-concatenated-stream (&rest 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)
+ ((null streams)
(if eof-errorp
(error 'end-of-file :stream stream)
(- numbytes remaining-bytes)))
- (let* ((stream (car current))
+ (let* ((stream (car streams))
(bytes-read (read-n-bytes stream buffer current-start
remaining-bytes nil)))
(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)))
- (when left
- (let* ((current (car left)))
- (case operation
- (:listen
- (loop
- (let ((stuff (if (ansi-stream-p current)
- (funcall (ansi-stream-misc current) current
- :listen)
- (stream-misc-dispatch current :listen))))
- (cond ((eq stuff :eof)
- ;; Advance CURRENT, and try again.
- (pop (concatenated-stream-current stream))
- (setf current
- (car (concatenated-stream-current stream)))
- (unless current
- ;; No further streams. EOF.
- (return :eof)))
- (stuff
- ;; Stuff's available.
- (return t))
- (t
- ;; Nothing is available yet.
- (return nil))))))
- (:clear-input (clear-input current))
- (:unread (unread-char arg1 current))
- (:close
- (set-closed-flame stream))
- (t
- (if (ansi-stream-p current)
- (funcall (ansi-stream-misc current) current operation arg1 arg2)
- (stream-misc-dispatch current operation arg1 arg2))))))))
+ (let* ((left (concatenated-stream-streams stream))
+ (current (car left)))
+ (case operation
+ (:listen
+ (unless left
+ (return-from concatenated-misc :eof))
+ (loop
+ (let ((stuff (if (ansi-stream-p current)
+ (funcall (ansi-stream-misc current) current
+ :listen)
+ (stream-misc-dispatch current :listen))))
+ (cond ((eq stuff :eof)
+ ;; Advance STREAMS, and try again.
+ (pop (concatenated-stream-streams stream))
+ (setf current
+ (car (concatenated-stream-streams stream)))
+ (unless current
+ ;; No further streams. EOF.
+ (return :eof)))
+ (stuff
+ ;; Stuff's available.
+ (return t))
+ (t
+ ;; Nothing is available yet.
+ (return nil))))))
+ (:clear-input (when left (clear-input current)))
+ (:unread (when left (unread-char arg1 current)))
+ (:close
+ (set-closed-flame stream))
+ (t
+ (when left
+ (if (ansi-stream-p current)
+ (funcall (ansi-stream-misc current) current operation arg1 arg2)
+ (stream-misc-dispatch current operation arg1 arg2)))))))
\f
;;;; echo streams
(in #'echo-in)
(bin #'echo-bin)
(misc #'echo-misc)
- (n-bin #'ill-bin))
+ (n-bin #'echo-n-bin))
(:constructor %make-echo-stream (input-stream output-stream))
(:copier nil))
unread-stuff)
"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)))
(funcall #'%make-echo-stream input-stream output-stream))
-(macrolet ((in-fun (name fun out-slot stream-method &rest args)
+(macrolet ((in-fun (name in-fun out-fun &rest args)
`(defun ,name (stream ,@args)
(or (pop (echo-stream-unread-stuff stream))
(let* ((in (echo-stream-input-stream stream))
(out (echo-stream-output-stream stream))
- (result (,fun in ,@args)))
- (if (ansi-stream-p out)
- (funcall (,out-slot out) out result)
- (,stream-method out result))
- result)))))
- (in-fun echo-in read-char ansi-stream-out stream-write-char
- eof-error-p eof-value)
- (in-fun echo-bin read-byte ansi-stream-bout stream-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)))))))
+ (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))
+
+(defun echo-n-bin (stream buffer start numbytes eof-error-p)
+ (let ((new-start start)
+ (read 0))
+ (loop
+ (let ((thing (pop (echo-stream-unread-stuff stream))))
+ (cond
+ (thing
+ (setf (aref buffer new-start) thing)
+ (incf new-start)
+ (incf read)
+ (when (= read numbytes)
+ (return-from echo-n-bin numbytes)))
+ (t (return nil)))))
+ (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
+ new-start (- numbytes read) nil)))
+ (cond
+ ((not eof-error-p)
+ (write-sequence buffer (echo-stream-output-stream stream)
+ :start new-start :end (+ new-start bytes-read))
+ (+ bytes-read read))
+ ((> numbytes (+ read bytes-read))
+ (write-sequence buffer (echo-stream-output-stream stream)
+ :start new-start :end (+ new-start bytes-read))
+ (error 'end-of-file :stream stream))
+ (t
+ (write-sequence buffer (echo-stream-output-stream stream)
+ :start new-start :end (+ new-start bytes-read))
+ (aver (= numbytes (+ new-start bytes-read)))
+ numbytes)))))
\f
;;;; base STRING-STREAM stuff
(defstruct (string-input-stream
(:include string-stream
(in #'string-inch)
- (bin #'string-binch)
- (n-bin #'string-stream-read-n-bytes)
+ (bin #'ill-bin)
+ (n-bin #'ill-bin)
(misc #'string-in-misc)
- (string (missing-arg)
- :type (simple-array character (*))))
+ (string (missing-arg) :type simple-string))
(:constructor internal-make-string-input-stream
(string current end))
(:copier nil))
- (current nil :type index)
- (end nil :type index))
+ (current (missing-arg) :type index)
+ (end (missing-arg) :type index))
(defun string-inch (stream eof-error-p eof-value)
+ (declare (type string-input-stream stream))
(let ((string (string-input-stream-string stream))
(index (string-input-stream-current stream)))
- (declare (type (simple-array character (*)) string)
- (type fixnum index))
- (cond ((= index (the index (string-input-stream-end stream)))
+ (cond ((>= index (the index (string-input-stream-end stream)))
(eof-or-lose stream eof-error-p eof-value))
(t
(setf (string-input-stream-current stream) (1+ index))
- (aref string index)))))
+ (char string index)))))
(defun string-binch (stream eof-error-p eof-value)
+ (declare (type string-input-stream stream))
(let ((string (string-input-stream-string stream))
(index (string-input-stream-current stream)))
- (declare (type (simple-array character (*)) string)
- (type index index))
- (cond ((= index (the index (string-input-stream-end stream)))
+ (cond ((>= index (the index (string-input-stream-end stream)))
(eof-or-lose stream eof-error-p eof-value))
(t
(setf (string-input-stream-current stream) (1+ index))
- (char-code (aref string index))))))
+ (char-code (char string index))))))
(defun string-stream-read-n-bytes (stream buffer start requested eof-error-p)
(declare (type string-input-stream stream)
(index (string-input-stream-current stream))
(available (- (string-input-stream-end stream) index))
(copy (min available requested)))
- (declare (type (simple-array character (*)) string)
- (type index index available copy))
+ (declare (type simple-string string))
(when (plusp copy)
(setf (string-input-stream-current stream)
(truly-the index (+ index copy)))
copy)))
(defun string-in-misc (stream operation &optional arg1 arg2)
- (declare (ignore arg2))
+ (declare (type string-input-stream stream)
+ (ignore arg2))
(case operation
(:file-position
(if arg1
(case arg1
(:start 0)
(:end (string-input-stream-end stream))
+ ;; We allow moving position beyond EOF. Errors happen
+ ;; on read, not move -- or the user may extend the
+ ;; input string.
(t arg1)))
(string-input-stream-current stream)))
- (:file-length (length (string-input-stream-string stream)))
+ ;; According to ANSI: "Should signal an error of type type-error
+ ;; if stream is not a stream associated with a file."
+ ;; This is checked by FILE-LENGTH, so no need to do it here either.
+ ;; (:file-length (length (string-input-stream-string stream)))
(:unread (decf (string-input-stream-current stream)))
- (:listen (or (/= (the fixnum (string-input-stream-current stream))
- (the fixnum (string-input-stream-end stream)))
+ (:close (set-closed-flame stream))
+ (:listen (or (/= (the index (string-input-stream-current stream))
+ (the index (string-input-stream-end stream)))
:eof))
- (:element-type 'base-char)))
+ (:element-type (array-element-type (string-input-stream-string stream)))))
-(defun make-string-input-stream (string &optional
- (start 0) end)
+(defun make-string-input-stream (string &optional (start 0) end)
#!+sb-doc
"Return an input stream which will supply the characters of STRING between
START and END in order."
(declare (type string string)
(type index start)
(type (or index null) end))
-
- (internal-make-string-input-stream
- (coerce string 'simple-string)
- start
- (%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
+ start
+ end))))
\f
;;;; STRING-OUTPUT-STREAM stuff
(:copier nil))
;; Index of the next location to use.
(index 0 :type fixnum)
+ ;; Index cache for string-output-stream-last-index
+ (index-cache 0 :type fixnum)
;; Requested element type
(element-type 'character))
"Return an output stream which will accumulate all output given it for
the benefit of the function GET-OUTPUT-STREAM-STRING.")
+(defun string-output-stream-last-index (stream)
+ (max (string-output-stream-index stream)
+ (string-output-stream-index-cache stream)))
+
(defun string-ouch (stream character)
(let ((current (string-output-stream-index stream))
(workspace (string-output-stream-string stream)))
(if (= current (the fixnum (length workspace)))
(let ((new-workspace (make-string (* current 2))))
(replace new-workspace workspace)
- (setf (aref new-workspace current) character)
- (setf (string-output-stream-string stream) new-workspace))
+ (setf (aref new-workspace current) character
+ (string-output-stream-string stream) new-workspace))
(setf (aref workspace current) character))
(setf (string-output-stream-index stream) (1+ current))))
(declare (ignore arg2))
(case operation
(:file-position
- (if (null arg1)
+ (if arg1
+ (let ((end (string-output-stream-last-index stream)))
+ (setf (string-output-stream-index-cache stream) end
+ (string-output-stream-index stream)
+ (case arg1
+ (:start 0)
+ (:end end)
+ (t
+ ;; We allow moving beyond the end of stream,
+ ;; implicitly extending the output stream.
+ (let ((buffer (string-output-stream-string stream)))
+ (when (> arg1 (length buffer))
+ (setf (string-output-stream-string stream)
+ (make-string
+ arg1 :element-type (array-element-type buffer))
+ (subseq (string-output-stream-string stream)
+ 0 end)
+ (subseq buffer 0 end))))
+ arg1))))
(string-output-stream-index stream)))
+ (:close (set-closed-flame stream))
(:charpos
(do ((index (1- (the fixnum (string-output-stream-index stream)))
(1- index))
(type fixnum index count))
(if (char= (schar string index) #\newline)
(return count))))
- (:element-type 'base-char)))
+ (:element-type (array-element-type (string-output-stream-string stream)))))
;;; Return a string of all the characters sent to a stream made by
;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function.
(defun get-output-stream-string (stream)
(declare (type string-output-stream stream))
- (let* ((length (string-output-stream-index stream))
+ (let* ((length (string-output-stream-last-index stream))
(element-type (string-output-stream-element-type stream))
(result
(case element-type
(replace result (string-output-stream-string stream)))
((simple-array nil (*))
(replace result (string-output-stream-string stream))))
- (setf (string-output-stream-index stream) 0)
+ (setf (string-output-stream-index stream) 0
+ (string-output-stream-index-cache stream) 0)
result))
;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as
(%write-string (string-output-stream-string in-stream)
out-stream
0
- (string-output-stream-index in-stream))
- (setf (string-output-stream-index in-stream) 0))
+ (string-output-stream-last-index in-stream))
+ (setf (string-output-stream-index in-stream) 0
+ (string-output-stream-index-cache in-stream) 0))
\f
;;;; fill-pointer streams
(misc #'fill-pointer-misc)
;; a string with a fill pointer where we stuff
;; the stuff we write
- (string (error "missing argument")
+ (string (missing-arg)
:type string-with-fill-pointer
:read-only t))
(:constructor make-fill-pointer-output-stream (string))
(declare (simple-string new-workspace))
(%byte-blt workspace start
new-workspace 0 current)
- (setf workspace new-workspace)
- (setf offset-current current)
+ (setf workspace new-workspace
+ offset-current current)
(set-array-header buffer workspace new-length
current+1 0 new-length nil))
(setf (fill-pointer buffer) current+1))
dst-end))
(defun fill-pointer-misc (stream operation &optional arg1 arg2)
- (declare (ignore arg1 arg2))
+ (declare (ignore arg2))
(case operation
+ (:file-position
+ (let ((buffer (fill-pointer-output-stream-string stream)))
+ (if arg1
+ (setf (fill-pointer buffer)
+ (case arg1
+ (:start 0)
+ ;; Fill-pointer is always at fill-pointer we will
+ ;; make :END move to the end of the actual string.
+ (:end (array-total-size buffer))
+ ;; We allow moving beyond the end of string if the
+ ;; string is adjustable.
+ (t (when (>= arg1 (array-total-size buffer))
+ (if (adjustable-array-p buffer)
+ (adjust-array buffer arg1)
+ (error "Cannot move FILE-POSITION beyond the end ~
+ of WITH-OUTPUT-TO-STRING stream ~
+ constructed with non-adjustable string.")))
+ arg1)))
+ (fill-pointer buffer))))
(:charpos
(let* ((buffer (fill-pointer-output-stream-string stream))
(current (fill-pointer buffer)))
(if found
(- end (the fixnum found))
current)))))
- (:element-type 'base-char)))
+ (:element-type (array-element-type
+ (fill-pointer-output-stream-string stream)))))
\f
;;;; indenting streams
(indentation (indenting-stream-indentation ,stream)))
((>= i indentation))
(%write-string
- " "
+ #.(make-string 60 :initial-element #\Space)
,sub-stream
0
(min 60 (- indentation i)))))
#!+sb-doc
"Return a stream that sends all output to the stream TARGET, but modifies
the case of letters, depending on KIND, which should be one of:
- :upcase - convert to upper case.
- :downcase - convert to lower case.
- :capitalize - convert the first letter of words to upper case and the
- rest of the word to lower case.
- :capitalize-first - convert the first letter of the first word to upper
- case and everything else to lower case."
+ :UPCASE - convert to upper case.
+ :DOWNCASE - convert to lower case.
+ :CAPITALIZE - convert the first letter of words to upper case and the
+ rest of the word to lower case.
+ :CAPITALIZE-FIRST - convert the first letter of the first word to upper
+ case and everything else to lower case."
(declare (type stream target)
(type (member :upcase :downcase :capitalize :capitalize-first)
kind)
(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)
(defun case-frob-upcase-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(defun case-frob-downcase-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(defun case-frob-capitalize-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(defun case-frob-capitalize-aux-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(defun case-frob-capitalize-first-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
+ (type simple-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(list
(let ((read-function
(if (subtypep (stream-element-type stream) 'character)
- #'read-char
- #'read-byte)))
+ #'ansi-stream-read-char
+ #'ansi-stream-read-byte)))
(do ((rem (nthcdr start seq) (rest rem))
(i start (1+ i)))
((or (endp rem) (>= i end)) i)
(declare (type list rem)
(type index i))
- (let ((el (funcall read-function stream nil :eof)))
+ (let ((el (funcall read-function stream nil :eof nil)))
(when (eq el :eof)
(return i))
(setf (first rem) el)))))
(with-array-data ((data seq) (offset-start start) (offset-end end))
(typecase data
((or (simple-array (unsigned-byte 8) (*))
- (simple-array (signed-byte 8) (*))
- simple-string)
+ (simple-array (signed-byte 8) (*)))
(let* ((numbytes (- end start))
- (bytes-read (sb!sys:read-n-bytes stream
- data
- offset-start
- numbytes
- nil)))
+ (bytes-read (read-n-bytes stream data offset-start
+ numbytes nil)))
(if (< bytes-read numbytes)
(+ start bytes-read)
end)))
(t
(let ((read-function
(if (subtypep (stream-element-type stream) 'character)
- #'read-char
- #'read-byte)))
+ #'ansi-stream-read-char
+ #'ansi-stream-read-byte)))
(do ((i offset-start (1+ i)))
((>= i offset-end) end)
(declare (type index i))
- (let ((el (funcall read-function stream nil :eof)))
+ (let ((el (funcall read-function stream nil :eof nil)))
(when (eq el :eof)
(return (+ start (- i offset-start))))
(setf (aref data i) el)))))))))))
(list
(let ((write-function
(if (subtypep (stream-element-type stream) 'character)
+ ;; FIXME (rudi 2004-08-09): since we know we're an
+ ;; ansi stream here, we could replace these
+ ;; functions with ansi-stream-specific constructs
#'write-char
#'write-byte)))
(do ((rem (nthcdr start seq) (rest rem))
(vector
(let ((write-function
(if (subtypep (stream-element-type stream) 'character)
+ ;; FIXME (rudi 2004-08-09): since we know we're an
+ ;; ansi stream here, we could replace these
+ ;; functions with ansi-specific constructs
#'write-char
#'write-byte)))
(do ((i start (1+ i)))
(funcall write-function (aref seq i) stream)))))))
\f
;;;; etc.
-
-;;; (These were inline throughout this file, but that's not appropriate
-;;; globally.)
-(declaim (maybe-inline read-char unread-char read-byte listen))