(in-package "SB!IMPL")
-(deftype string-stream ()
- '(or string-input-stream string-output-stream
- fill-pointer-output-stream))
-
;;;; standard streams
;;; The initialization of these streams is performed by
(defun closed-flame (stream &rest ignore)
(declare (ignore ignore))
(error "~S is closed." stream))
-(defun do-nothing (&rest ignore)
+(defun no-op-placeholder (&rest ignore)
(declare (ignore ignore)))
\f
;;; stream manipulation functions
-(defun input-stream-p (stream)
- (declare (type stream stream))
+(declaim (inline ansi-stream-input-stream-p))
+(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))))
- (and (ansi-stream-p stream)
- (not (eq (ansi-stream-in stream) #'closed-flame))
+ (and (not (eq (ansi-stream-in stream) #'closed-flame))
;;; KLUDGE: It's probably not good to have EQ tests on function
;;; values like this. What if someone's redefined the function?
;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
(or (not (eq (ansi-stream-in stream) #'ill-in))
(not (eq (ansi-stream-bin stream) #'ill-bin)))))
-(defun output-stream-p (stream)
+(defun input-stream-p (stream)
(declare (type stream stream))
+ (and (ansi-stream-p stream)
+ (ansi-stream-input-stream-p stream)))
+
+(declaim (inline ansi-stream-output-stream-p))
+(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))))
- (and (ansi-stream-p stream)
- (not (eq (ansi-stream-in stream) #'closed-flame))
+ (and (not (eq (ansi-stream-in stream) #'closed-flame))
(or (not (eq (ansi-stream-out stream) #'ill-out))
(not (eq (ansi-stream-bout stream) #'ill-bout)))))
-(defun open-stream-p (stream)
+(defun output-stream-p (stream)
(declare (type stream stream))
+
+ (and (ansi-stream-p stream)
+ (ansi-stream-output-stream-p stream)))
+
+(declaim (inline ansi-stream-open-stream-p))
+(defun ansi-stream-open-stream-p (stream)
+ (declare (type ansi-stream stream))
(not (eq (ansi-stream-in stream) #'closed-flame)))
-(defun stream-element-type (stream)
- (declare (type stream stream))
+(defun open-stream-p (stream)
+ (ansi-stream-open-stream-p stream))
+
+(declaim (inline ansi-stream-element-type))
+(defun ansi-stream-element-type (stream)
+ (declare (type ansi-stream stream))
(funcall (ansi-stream-misc stream) stream :element-type))
+(defun stream-element-type (stream)
+ (ansi-stream-element-type stream))
+
(defun interactive-stream-p (stream)
(declare (type stream stream))
(funcall (ansi-stream-misc stream) stream :interactive-p))
-(defun close (stream &key abort)
- (declare (type stream stream))
+(declaim (inline ansi-stream-close))
+(defun ansi-stream-close (stream abort)
+ (declare (type ansi-stream stream))
(when (open-stream-p stream)
(funcall (ansi-stream-misc stream) stream :close abort))
t)
+(defun close (stream &key abort)
+ (ansi-stream-close stream abort))
+
(defun set-closed-flame (stream)
(setf (ansi-stream-in stream) #'closed-flame)
(setf (ansi-stream-bin stream) #'closed-flame)
;; private predicate function..) is ugly and confusing, but
;; I can't see any other way. -- WHN 2001-04-14
:expected-type '(satisfies stream-associated-with-file-p)
- :format-string
+ :format-control
"~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
:format-arguments (list stream))))
;;; like FILE-POSITION, only using :FILE-LENGTH
(defun file-length (stream)
- (declare (type (or file-stream synonym-stream) stream))
+ ;; FIXME: The following declaration uses yet undefined types, which
+ ;; cause cross-compiler hangup.
+ ;;
+ ;; (declare (type (or file-stream synonym-stream) stream))
(stream-must-be-associated-with-file stream)
(funcall (ansi-stream-misc stream) stream :file-length))
\f
(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)
: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
- (error "internal error: 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
- (error "internal error: impossible case"))))))
+ (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)))
(stream-fresh-line stream))))
(defun write-string (string &optional (stream *standard-output*)
- &key (start 0) (end nil))
- (%write-string string stream start (or end (length string)))
- string)
-
-(defun %write-string (string stream start end)
+ &key (start 0) end)
(declare (type string string))
- (declare (type streamlike stream))
- (declare (type index start end))
-
;; Note that even though you might expect, based on the behavior of
;; things like AREF, that the correct upper bound here is
;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
;; "bounding index" and "length" indicate that in this case (i.e.
- ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
- ;; which are implemented in terms of this function), (LENGTH STRING)
- ;; is the required upper bound. A foolish consistency is the
- ;; hobgoblin of lesser languages..
- (unless (<= 0 start end (length string))
- (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
- start
- end
- string))
+ ;; for the ANSI-specified functions WRITE-STRING [and WRITE-LINE]),
+ ;; (LENGTH STRING) is the required upper bound. A foolish
+ ;; consistency is the hobgoblin of lesser languages..
+ (%write-string string stream start (%check-vector-sequence-bounds
+ string start end))
+ string)
+(defun %write-string (string stream start end)
+ (declare (type string string))
+ (declare (type streamlike stream))
+ (declare (type index start end))
(let ((stream (out-synonym-of stream)))
(cond ((ansi-stream-p stream)
(if (array-header-p string)
(stream-write-string stream string start end)))))
(defun write-line (string &optional (stream *standard-output*)
- &key (start 0) (end nil))
- (let ((defaulted-stream (out-synonym-of stream))
- (defaulted-end (or end (length string))))
- (%write-string string defaulted-stream start defaulted-end)
+ &key (start 0) end)
+ (declare (type string string))
+ ;; FIXME: Why is there this difference between the treatments of the
+ ;; STREAM argument in WRITE-STRING and WRITE-LINE?
+ (let ((defaulted-stream (out-synonym-of stream)))
+ (%write-string string defaulted-stream start (%check-vector-sequence-bounds
+ string start end))
(write-char #\newline defaulted-stream))
string)
(bout #'broadcast-bout)
(sout #'broadcast-sout)
(misc #'broadcast-misc))
- (:constructor #!-high-security-support
- make-broadcast-stream
- #!+high-security-support
- %make-broadcast-stream (&rest
- streams))
+ (:constructor %make-broadcast-stream
+ (&rest streams))
(:copier nil))
;; a list of all the streams we broadcast to
(streams () :type list :read-only t))
-#!+high-security-support
(defun make-broadcast-stream (&rest streams)
(dolist (stream streams)
(unless (or (and (synonym-stream-p stream)
(bout #'two-way-bout)
(sout #'two-way-sout)
(misc #'two-way-misc))
- (:constructor #!-high-security-support
- make-two-way-stream
- #!+high-security-support
- %make-two-way-stream (input-stream output-stream))
+ (:constructor %make-two-way-stream (input-stream output-stream))
(:copier nil))
(input-stream (missing-arg) :type stream :read-only t)
(output-stream (missing-arg) :type stream :read-only t))
(defprinter (two-way-stream) input-stream output-stream)
-#!-high-security-support
-(setf (fdocumentation 'make-two-way-stream 'function)
- "Return a bidirectional stream which gets its input from Input-Stream and
- sends its output to Output-Stream.")
-#!+high-security-support
(defun make-two-way-stream (input-stream output-stream)
#!+sb-doc
- "Return a bidirectional stream which gets its input from Input-Stream and
- sends its output to Output-Stream."
+ "Return a bidirectional stream which gets its input from INPUT-STREAM and
+ sends its output to OUTPUT-STREAM."
;; 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.
(bin #'concatenated-bin)
(n-bin #'concatenated-n-bin)
(misc #'concatenated-misc))
- (:constructor
- #!-high-security-support make-concatenated-stream
- #!+high-security-support %make-concatenated-stream
- (&rest streams &aux (current streams)))
+ (:constructor %make-concatenated-stream
+ (&rest streams &aux (current streams)))
(:copier nil))
;; The car of this is the substream we are reading from now.
current
":STREAMS ~S"
(concatenated-stream-streams x))))
-#!-high-security-support
-(setf (fdocumentation 'make-concatenated-stream 'function)
- "Return a stream which takes its input from each of the Streams in turn,
- going on to the next at EOF.")
-
-#!+high-security-support
(defun make-concatenated-stream (&rest streams)
#!+sb-doc
- "Return a stream which takes its input from each of the Streams in turn,
+ "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)
(let* ((stream (car current))
(result (,fun stream nil nil)))
(when result (return result)))
- (setf (concatenated-stream-current stream) current)))))
+ (pop (concatenated-stream-current stream))))))
(in-fun concatenated-in read-char)
(in-fun concatenated-bin read-byte))
(bin #'echo-bin)
(misc #'echo-misc)
(n-bin #'ill-bin))
- (:constructor make-echo-stream (input-stream output-stream))
+ (:constructor %make-echo-stream (input-stream output-stream))
(:copier nil))
unread-stuff)
(def!method print-object ((x echo-stream) stream)
(two-way-stream-input-stream x)
(two-way-stream-output-stream x))))
+(defun make-echo-stream (input-stream output-stream)
+ #!+sb-doc
+ "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))
+ (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))
+ (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)
`(defun ,name (stream ,@args)
(or (pop (echo-stream-unread-stuff stream))
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)
(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
-#!+sb-doc
-(setf (fdocumentation 'make-echo-stream 'function)
- "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")
+(defstruct (string-stream
+ (:include ansi-stream)
+ (:constructor nil)
+ (:copier nil))
+ (string nil :type string))
\f
-;;;; string input streams
+;;;; STRING-INPUT-STREAM stuff
(defstruct (string-input-stream
- (:include ansi-stream
+ (:include string-stream
(in #'string-inch)
(bin #'string-binch)
(n-bin #'string-stream-read-n-bytes)
- (misc #'string-in-misc))
+ (misc #'string-in-misc)
+ (string nil :type simple-string))
(:constructor internal-make-string-input-stream
(string current end))
(:copier nil))
- (string nil :type simple-string)
(current nil :type index)
(end nil :type index))
(:element-type 'base-char)))
(defun make-string-input-stream (string &optional
- (start 0) (end (length string)))
+ (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))
-
- #!+high-security
- (when (> end (length string))
- (cerror "Continue with end changed from ~S to ~S"
- "Write-string: end (~S) is larger then the length of the string (~S)"
- end (1- (length string))))
-
- (internal-make-string-input-stream (coerce string 'simple-string)
- start end))
+
+ (internal-make-string-input-stream
+ (coerce string 'simple-string)
+ start
+ (%check-vector-sequence-bounds string start end)))
\f
-;;;; string output streams
+;;;; STRING-OUTPUT-STREAM stuff
(defstruct (string-output-stream
- (:include ansi-stream
+ (:include string-stream
(out #'string-ouch)
(sout #'string-sout)
- (misc #'string-out-misc))
+ (misc #'string-out-misc)
+ ;; The string we throw stuff in.
+ (string (make-string 40) :type simple-string))
(:constructor make-string-output-stream ())
(:copier nil))
- ;; The string we throw stuff in.
- (string (make-string 40) :type simple-string)
;; Index of the next location to use.
(index 0 :type fixnum))
;;; the CLM, but they are required for the implementation of
;;; WITH-OUTPUT-TO-STRING.
+(deftype string-with-fill-pointer ()
+ '(and string
+ (satisfies array-has-fill-pointer-p)))
+
(defstruct (fill-pointer-output-stream
- (:include ansi-stream
+ (:include string-stream
(out #'fill-pointer-ouch)
(sout #'fill-pointer-sout)
- (misc #'fill-pointer-misc))
+ (misc #'fill-pointer-misc)
+ ;; a string with a fill pointer where we stuff
+ ;; the stuff we write
+ (string (error "missing argument")
+ :type string-with-fill-pointer
+ :read-only t))
(:constructor make-fill-pointer-output-stream (string))
- (:copier nil))
- ;; the string we throw stuff in
- string)
+ (:copier nil)))
(defun fill-pointer-ouch (stream character)
(let* ((buffer (fill-pointer-output-stream-string stream))
(defstruct (case-frob-stream
(:include ansi-stream
- (:misc #'case-frob-misc))
+ (misc #'case-frob-misc))
(:constructor %make-case-frob-stream (target out sout))
(:copier nil))
(target (missing-arg) :type stream))
(funcall (ansi-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
\f
-;;;; stream commands
-
-(defstruct (stream-command (:constructor make-stream-command
- (name &optional args))
- (:copier nil))
- (name nil :type symbol)
- (args nil :type list))
-(def!method print-object ((obj stream-command) str)
- (print-unreadable-object (obj str :type t :identity t)
- (prin1 (stream-command-name obj) str)))
-
-;;; Take a stream and wait for text or a command to appear on it. If
-;;; text appears before a command, return NIL, otherwise return a
-;;; command.
-;;;
-;;; We can't simply call the stream's misc method because NIL is an
-;;; ambiguous return value: does it mean text arrived, or does it mean
-;;; the stream's misc method had no :GET-COMMAND implementation? We
-;;; can't return NIL until there is text input. We don't need to loop
-;;; because any stream implementing :GET-COMMAND would wait until it
-;;; had some input. If the LISTEN fails, then we have some stream we
-;;; must wait on.
-(defun get-stream-command (stream)
- (let ((cmdp (funcall (ansi-stream-misc stream) stream :get-command)))
- (cond (cmdp)
- ((listen stream)
- nil)
- (t
- ;; This waits for input and returns NIL when it arrives.
- (unread-char (read-char stream) stream)))))
-\f
;;;; READ-SEQUENCE
-(defun read-sequence (seq stream &key (start 0) (end nil))
+(defun read-sequence (seq stream &key (start 0) end)
#!+sb-doc
"Destructively modify SEQ by reading elements from STREAM.
That part of SEQ bounded by START and END is destructively modified by
projects / sbcl.git / blobdiff