(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
;;; STREAM-COLD-INIT-OR-RESET.
-(defvar *terminal-io* () #!+sb-doc "Terminal I/O stream.")
-(defvar *standard-input* () #!+sb-doc "Default input stream.")
-(defvar *standard-output* () #!+sb-doc "Default output stream.")
-(defvar *error-output* () #!+sb-doc "Error output stream.")
-(defvar *query-io* () #!+sb-doc "Query I/O stream.")
-(defvar *trace-output* () #!+sb-doc "Trace output stream.")
-(defvar *debug-io* () #!+sb-doc "Interactive debugging stream.")
+(defvar *terminal-io* () #!+sb-doc "terminal I/O stream")
+(defvar *standard-input* () #!+sb-doc "default input stream")
+(defvar *standard-output* () #!+sb-doc "default output stream")
+(defvar *error-output* () #!+sb-doc "error output stream")
+(defvar *query-io* () #!+sb-doc "query I/O stream")
+(defvar *trace-output* () #!+sb-doc "trace output stream")
+(defvar *debug-io* () #!+sb-doc "interactive debugging stream")
(defun ill-in (stream &rest ignore)
(declare (ignore ignore))
(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
-;;; HOW THE STREAM STRUCTURE IS USED:
-;;;
-;;; Many of the slots of the stream structure contain functions
-;;; which are called to perform some operation on the stream. Closed
-;;; streams have #'Closed-Flame in all of their function slots. If
-;;; one side of an I/O or echo stream is closed, the whole stream is
-;;; considered closed. The functions in the operation slots take
-;;; arguments as follows:
-;;;
-;;; In: Stream, Eof-Errorp, Eof-Value
-;;; Bin: Stream, Eof-Errorp, Eof-Value
-;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp
-;;; Out: Stream, Character
-;;; Bout: Stream, Integer
-;;; Sout: Stream, String, Start, End
-;;; Misc: Stream, Operation, &Optional Arg1, Arg2
-;;;
-;;; In order to save space, some of the less common stream operations
-;;; are handled by just one function, the Misc method. This function
-;;; is passed a keyword which indicates the operation to perform.
-;;; The following keywords are used:
-;;; :listen - Return the following values:
-;;; t if any input waiting.
-;;; :eof if at eof.
-;;; nil if no input is available and not at eof.
-;;; :unread - Unread the character Arg.
-;;; :close - Do any stream specific stuff to close the stream.
-;;; The methods are set to closed-flame by the close
-;;; function, so that need not be done by this
-;;; function.
-;;; :clear-input - Clear any unread input
-;;; :finish-output,
-;;; :force-output - Cause output to happen
-;;; :clear-output - Clear any undone output
-;;; :element-type - Return the type of element the stream deals wit<h.
-;;; :line-length - Return the length of a line of output.
-;;; :charpos - Return current output position on the line.
-;;; :file-length - Return the file length of a file stream.
-;;; :file-position - Return or change the current position of a file stream.
-;;; :file-name - Return the name of an associated file.
-;;; :interactive-p - Is this an interactive device?
-;;;
-;;; In order to do almost anything useful, it is necessary to
-;;; define a new type of structure that includes stream, so that the
-;;; stream can have some state information.
-;;;
-;;; THE STREAM IN-BUFFER:
-;;;
-;;; The In-Buffer in the stream holds characters or bytes that
-;;; are ready to be read by some input function. If there is any
-;;; stuff in the In-Buffer, then the reading function can use it
-;;; without calling any stream method. Any stream may put stuff in
-;;; the In-Buffer, and may also assume that any input in the In-Buffer
-;;; has been consumed before any in-method is called. If a text
-;;; stream has in In-Buffer, then the first character should not be
-;;; used to buffer normal input so that it is free for unreading into.
-;;;
-;;; The In-Buffer slot is a vector In-Buffer-Length long. The
-;;; In-Index is the index in the In-Buffer of the first available
-;;; object. The available objects are thus between In-Index and the
-;;; length of the In-Buffer.
-;;;
-;;; When this buffer is only accessed by the normal stream
-;;; functions, the number of function calls is halved, thus
-;;; potentially doubling the speed of simple operations. If the
-;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
-;;; function call overhead is removed, vastly speeding up these
-;;; important operations.
-;;;
-;;; If a stream does not have an In-Buffer, then the In-Buffer slot
-;;; must be nil, and the In-Index must be In-Buffer-Length. These are
-;;; the default values for the slots.
-\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 (lisp-stream-p stream)
- (not (eq (lisp-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
;;; VALID-FOR-OUTPUT flags? -- WHN 19990902
- (or (not (eq (lisp-stream-in stream) #'ill-in))
- (not (eq (lisp-stream-bin stream) #'ill-bin)))))
+ (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 (lisp-stream-p stream)
- (not (eq (lisp-stream-in stream) #'closed-flame))
- (or (not (eq (lisp-stream-out stream) #'ill-out))
- (not (eq (lisp-stream-bout stream) #'ill-bout)))))
+ (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))
- (not (eq (lisp-stream-in stream) #'closed-flame)))
-(defun stream-element-type (stream)
- (declare (type stream stream))
- (funcall (lisp-stream-misc stream) stream :element-type))
+ (and (ansi-stream-p stream)
+ (ansi-stream-output-stream-p stream)))
-(defun interactive-stream-p (stream)
- (declare (type stream stream))
- (funcall (lisp-stream-misc stream) stream :interactive-p))
+(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 open-stream-p (stream)
- (declare (type stream stream))
- (not (eq (lisp-stream-in stream) #'closed-flame)))
+ (ansi-stream-open-stream-p stream))
-(defun close (stream &key abort)
+(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))
+
+(declaim (inline ansi-stream-close))
+(defun ansi-stream-close (stream abort)
+ (declare (type ansi-stream stream))
(when (open-stream-p stream)
- (funcall (lisp-stream-misc stream) stream :close abort))
+ (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 (lisp-stream-in stream) #'closed-flame)
- (setf (lisp-stream-bin stream) #'closed-flame)
- (setf (lisp-stream-n-bin stream) #'closed-flame)
- (setf (lisp-stream-in stream) #'closed-flame)
- (setf (lisp-stream-out stream) #'closed-flame)
- (setf (lisp-stream-bout stream) #'closed-flame)
- (setf (lisp-stream-sout stream) #'closed-flame)
- (setf (lisp-stream-misc stream) #'closed-flame))
+ (setf (ansi-stream-in stream) #'closed-flame)
+ (setf (ansi-stream-bin stream) #'closed-flame)
+ (setf (ansi-stream-n-bin stream) #'closed-flame)
+ (setf (ansi-stream-in stream) #'closed-flame)
+ (setf (ansi-stream-out stream) #'closed-flame)
+ (setf (ansi-stream-bout stream) #'closed-flame)
+ (setf (ansi-stream-sout stream) #'closed-flame)
+ (setf (ansi-stream-misc stream) #'closed-flame))
\f
;;;; file position and file length
-;;; Call the misc method with the :file-position operation.
+;;; Call the MISC method with the :FILE-POSITION operation.
(defun file-position (stream &optional position)
(declare (type stream stream))
(declare (type (or index (member nil :start :end)) position))
(cond
(position
- (setf (lisp-stream-in-index stream) in-buffer-length)
- (funcall (lisp-stream-misc stream) stream :file-position 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 (lisp-stream-misc stream) stream :file-position nil)))
- (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))
-
-;;; declaration test functions
-
-#!+high-security
-(defun stream-associated-with-file (stream)
- #!+sb-doc
- "Tests if the stream is associated with a file"
- (or (typep stream 'file-stream)
- (and (synonym-stream-p stream)
- (typep (symbol-value (synonym-stream-symbol stream))
- 'file-stream))))
-
-;;; Like File-Position, only use :file-length.
+ (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
+ (when res
+ (- res
+ (- +ansi-stream-in-buffer-length+
+ (ansi-stream-in-index stream))))))))
+
+;;; This is a literal translation of the ANSI glossary entry "stream
+;;; associated with a file".
+;;;
+;;; KLUDGE: Note that since Unix famously thinks "everything is a
+;;; file", and in particular stdin, stdout, and stderr are files, we
+;;; end up with this test being satisfied for weird things like
+;;; *STANDARD-OUTPUT* (to a tty). That seems unlikely to be what the
+;;; ANSI spec really had in mind, especially since this is used as a
+;;; qualification for operations like FILE-LENGTH (so that ANSI was
+;;; probably thinking of something like what Unix calls block devices)
+;;; but I can't see any better way to do it. -- WHN 2001-04-14
+(defun stream-associated-with-file-p (x)
+ "Test for the ANSI concept \"stream associated with a file\"."
+ (or (typep x 'file-stream)
+ (and (synonym-stream-p x)
+ (stream-associated-with-file-p (symbol-value
+ (synonym-stream-symbol x))))))
+
+(defun stream-must-be-associated-with-file (stream)
+ (declare (type stream stream))
+ (unless (stream-associated-with-file-p stream)
+ (error 'simple-type-error
+ ;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says
+ ;; this should be TYPE-ERROR. But what then can we use for
+ ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard
+ ;; 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-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))
-
- #!+high-security
- (check-type-var stream '(satisfies stream-associated-with-file)
- "a stream associated with a file")
-
- (funcall (lisp-stream-misc stream) stream :file-length))
+ ;; 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
;;;; input functions
recursive-p)
(declare (ignore recursive-p))
(let ((stream (in-synonym-of stream)))
- (if (lisp-stream-p stream)
+ (if (ansi-stream-p stream)
(prepare-for-fast-read-char stream
(let ((res (make-string 80))
(len 80)
(t
(done-with-fast-read-char)
(return (values (shrink-vector res index) t))))))))
- ;; must be FUNDAMENTAL-STREAM
+ ;; 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)
recursive-p)
(declare (ignore recursive-p))
(let ((stream (in-synonym-of stream)))
- (if (lisp-stream-p 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)))
- ;; FUNDAMENTAL-STREAM
+ ;; 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)
(defun unread-char (character &optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
- (if (lisp-stream-p stream)
- (let ((index (1- (lisp-stream-in-index stream)))
- (buffer (lisp-stream-in-buffer 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."))
+ (when (minusp index) (error "nothing to unread"))
(cond (buffer
(setf (aref buffer index) (char-code character))
- (setf (lisp-stream-in-index stream) index))
+ (setf (ansi-stream-in-index stream) index))
(t
- (funcall (lisp-stream-misc stream) stream
+ (funcall (ansi-stream-misc stream) stream
:unread character))))
- ;; Fundamental-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)
-
+ eof-value
+ recursive-p)
+ (declare (ignore recursive-p))
+ ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but
+ ;; the compiler doesn't seem to be smart enough to go from there to
+ ;; imposing a type check. Figure out why (because PEEK-TYPE is an
+ ;; &OPTIONAL argument?) and fix it, and then this explicit type
+ ;; check can go away.
+ (unless (typep peek-type '(or character boolean))
+ (error 'simple-type-error
+ :datum peek-type
+ :expected-type '(or character boolean)
+ :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"
+ :format-arguments (list peek-type '(or character boolean))))
(let ((stream (in-synonym-of stream)))
- (if (lisp-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)))
- (t
- (unread-char char stream)
- char)))
- ;; 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)))))
- (t
- (let ((char (stream-peek-char stream)))
- (if (eq char :eof)
- (eof-or-lose stream eof-error-p eof-value)
- char)))))))
+ (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 (lisp-stream-p stream)
- (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
- ;; Test for t explicitly since misc methods return :eof sometimes.
- (eq (funcall (lisp-stream-misc stream) stream :listen) t))
- ;; Fundamental-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))
+ ;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
(stream-listen stream))))
(defun read-char-no-hang (&optional (stream *standard-input*)
recursive-p)
(declare (ignore recursive-p))
(let ((stream (in-synonym-of stream)))
- (if (lisp-stream-p stream)
- (if (funcall (lisp-stream-misc stream) stream :listen)
- ;; On t or :eof get READ-CHAR to do the work.
+ (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)
- ;; Fundamental-stream.
+ ;; 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)
(defun clear-input (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
- (cond ((lisp-stream-p stream)
- (setf (lisp-stream-in-index stream) in-buffer-length)
- (funcall (lisp-stream-misc stream) stream :clear-input))
+ (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))))
nil)
(declaim (maybe-inline read-byte))
(defun read-byte (stream &optional (eof-error-p t) eof-value)
(let ((stream (in-synonym-of stream)))
- (if (lisp-stream-p 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)))
- ;; FUNDAMENTAL-STREAM
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-byte stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the
;;; number of bytes read.
;;;
-;;; Note: CMU CL's version of this had a special interpretation of EOF-ERROR-P
-;;; which SBCL does not have. (In the EOF-ERROR-P=NIL case, CMU CL's version
-;;; would return as soon as any data became available.) This could be useful
-;;; behavior for things like pipes in some cases, but it wasn't being used in
-;;; SBCL, so it was dropped. If we ever need it, it could be added later as a
-;;; new variant N-BIN method (perhaps N-BIN-ASAP?) or something.
+;;; Note: CMU CL's version of this had a special interpretation of
+;;; EOF-ERROR-P which SBCL does not have. (In the EOF-ERROR-P=NIL
+;;; case, CMU CL's version would return as soon as any data became
+;;; available.) This could be useful behavior for things like pipes in
+;;; some cases, but it wasn't being used in SBCL, so it was dropped.
+;;; If we ever need it, it could be added later as a new variant N-BIN
+;;; method (perhaps N-BIN-ASAP?) or something.
(defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t))
- (declare (type lisp-stream stream)
+ (declare (type ansi-stream stream)
(type index numbytes start)
(type (or (simple-array * (*)) system-area-pointer) buffer))
- (let* ((stream (in-synonym-of stream lisp-stream))
- (in-buffer (lisp-stream-in-buffer stream))
- (index (lisp-stream-in-index stream))
- (num-buffered (- in-buffer-length index)))
+ (let* ((stream (in-synonym-of stream ansi-stream))
+ (in-buffer (ansi-stream-in-buffer stream))
+ (index (ansi-stream-in-index stream))
+ (num-buffered (- +ansi-stream-in-buffer-length+ index)))
(declare (fixnum index num-buffered))
(cond
((not in-buffer)
- (funcall (lisp-stream-n-bin stream)
+ (funcall (ansi-stream-n-bin stream)
stream
buffer
start
numbytes
eof-error-p))
((<= numbytes num-buffered)
- (%primitive sb!c:byte-blt
- in-buffer
- index
- buffer
- start
- (+ start numbytes))
- (setf (lisp-stream-in-index stream) (+ index numbytes))
+ (%byte-blt in-buffer index
+ buffer start (+ start numbytes))
+ (setf (ansi-stream-in-index stream) (+ index numbytes))
numbytes)
(t
(let ((end (+ start num-buffered)))
- (%primitive sb!c:byte-blt in-buffer index buffer start end)
- (setf (lisp-stream-in-index stream) in-buffer-length)
- (+ (funcall (lisp-stream-n-bin stream)
+ (%byte-blt in-buffer index buffer start end)
+ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+ (+ (funcall (ansi-stream-n-bin stream)
stream
buffer
end
eof-error-p)
num-buffered))))))
-;;; the amount of space we leave at the start of the in-buffer for unreading
+;;; the amount of space we leave at the start of the in-buffer for
+;;; unreading
;;;
;;; (It's 4 instead of 1 to allow word-aligned copies.)
-(defconstant in-buffer-extra 4) ; FIXME: should be symbolic constant
+(defconstant +ansi-stream-in-buffer-extra+
+ 4) ; FIXME: should be symbolic constant
-;;; This function is called by the fast-read-char expansion to refill the
-;;; in-buffer for text streams. There is definitely an in-buffer, and hence
-;;; must be an n-bin method.
+;;; This function is called by the FAST-READ-CHAR expansion to refill
+;;; 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 (lisp-stream-in-buffer stream))
- (count (funcall (lisp-stream-n-bin stream)
+ (let* ((ibuf (ansi-stream-in-buffer stream))
+ (count (funcall (ansi-stream-n-bin stream)
stream
ibuf
- in-buffer-extra
- (- in-buffer-length in-buffer-extra)
+ +ansi-stream-in-buffer-extra+
+ (- +ansi-stream-in-buffer-length+
+ +ansi-stream-in-buffer-extra+)
nil))
- (start (- in-buffer-length count)))
+ (start (- +ansi-stream-in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
- (setf (lisp-stream-in-index stream) in-buffer-length)
- (funcall (lisp-stream-in stream) stream eof-error-p eof-value))
+ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
(t
- (when (/= start in-buffer-extra)
- (bit-bash-copy ibuf (+ (* in-buffer-extra sb!vm:byte-bits)
+ (when (/= start +ansi-stream-in-buffer-extra+)
+ (bit-bash-copy ibuf (+ (* +ansi-stream-in-buffer-extra+
+ sb!vm:n-byte-bits)
(* sb!vm:vector-data-offset
- sb!vm:word-bits))
- ibuf (+ (the index (* start sb!vm:byte-bits))
+ sb!vm:n-word-bits))
+ ibuf (+ (the index (* start sb!vm:n-byte-bits))
(* sb!vm:vector-data-offset
- sb!vm:word-bits))
- (* count sb!vm:byte-bits)))
- (setf (lisp-stream-in-index stream) (1+ start))
+ sb!vm:n-word-bits))
+ (* count sb!vm:n-byte-bits)))
+ (setf (ansi-stream-in-index stream) (1+ start))
(code-char (aref ibuf start))))))
-;;; Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
-;;; unreading.
+;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
+;;; leave room for unreading.
(defun fast-read-byte-refill (stream eof-error-p eof-value)
- (let* ((ibuf (lisp-stream-in-buffer stream))
- (count (funcall (lisp-stream-n-bin stream) stream
- ibuf 0 in-buffer-length
+ (let* ((ibuf (ansi-stream-in-buffer stream))
+ (count (funcall (ansi-stream-n-bin stream) stream
+ ibuf 0 +ansi-stream-in-buffer-length+
nil))
- (start (- in-buffer-length count)))
+ (start (- +ansi-stream-in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
- (setf (lisp-stream-in-index stream) in-buffer-length)
- (funcall (lisp-stream-bin stream) stream eof-error-p eof-value))
+ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-bin stream) stream eof-error-p eof-value))
(t
(unless (zerop start)
- (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:word-bits)
- ibuf (+ (the index (* start sb!vm:byte-bits))
+ (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:n-word-bits)
+ ibuf (+ (the index (* start sb!vm:n-byte-bits))
(* sb!vm:vector-data-offset
- sb!vm:word-bits))
- (* count sb!vm:byte-bits)))
- (setf (lisp-stream-in-index stream) (1+ start))
+ sb!vm:n-word-bits))
+ (* count sb!vm:n-byte-bits)))
+ (setf (ansi-stream-in-index stream) (1+ start))
(aref ibuf start)))))
\f
;;; output functions
(defun write-char (character &optional (stream *standard-output*))
- (with-out-stream stream (lisp-stream-out character)
+ (with-out-stream stream (ansi-stream-out character)
(stream-write-char character))
character)
(defun terpri (&optional (stream *standard-output*))
- (with-out-stream stream (lisp-stream-out #\newline) (stream-terpri))
+ (with-out-stream stream (ansi-stream-out #\newline) (stream-terpri))
nil)
(defun fresh-line (&optional (stream *standard-output*))
(let ((stream (out-synonym-of stream)))
- (if (lisp-stream-p stream)
+ (if (ansi-stream-p stream)
(when (/= (or (charpos stream) 1) 0)
- (funcall (lisp-stream-out stream) stream #\newline)
+ (funcall (ansi-stream-out stream) stream #\newline)
t)
- ;; Fundamental-stream.
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(stream-fresh-line stream))))
(defun write-string (string &optional (stream *standard-output*)
- &key (start 0) (end (length (the vector string))))
-
- ;; FIXME: These SETFs don't look right to me. Looking at the definition
- ;; of "bounding indices" in the glossary of the ANSI spec, and extrapolating
- ;; from the behavior of other operations when their operands are the
- ;; wrong type, it seems that it would be more correct to essentially
- ;; (ASSERT (<= 0 START END (LENGTH STRING)))
- ;; instead of modifying the incorrect values.
- #!+high-security
- (setf end (min end (length (the vector string))))
- #!+high-security
- (setf start (max start 0))
-
- ;; FIXME: And I'd just signal a non-continuable error..
- #!+high-security
- (when (< end start)
- (cerror "Continue with switched start and end ~S <-> ~S"
- "Write-string: start (~S) and end (~S) exchanged."
- start end string)
- (rotatef start end))
-
- (write-string* string stream start end))
+ &key (start 0) end)
+ (declare (type string string))
+ ;; 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]),
+ ;; (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 &optional (stream *standard-output*)
- (start 0) (end (length (the vector string))))
- (declare (fixnum start end))
+(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 ((lisp-stream-p stream)
+ (cond ((ansi-stream-p stream)
(if (array-header-p string)
(with-array-data ((data string) (offset-start start)
(offset-end end))
- (funcall (lisp-stream-sout stream)
+ (funcall (ansi-stream-sout stream)
stream data offset-start offset-end))
- (funcall (lisp-stream-sout stream) stream string start end))
+ (funcall (ansi-stream-sout stream) stream string start end))
string)
- (t ; Fundamental-stream.
+ (t ; must be Gray streams FUNDAMENTAL-STREAM
(stream-write-string stream string start end)))))
(defun write-line (string &optional (stream *standard-output*)
- &key (start 0) (end (length string)))
- (write-line* string stream start end))
-
-(defun write-line* (string &optional (stream *standard-output*)
- (start 0) (end (length string)))
- (declare (fixnum start end))
- (let ((stream (out-synonym-of stream)))
- (cond ((lisp-stream-p stream)
- (if (array-header-p string)
- (with-array-data ((data string) (offset-start start)
- (offset-end end))
- (with-out-stream stream (lisp-stream-sout data offset-start
- offset-end)))
- (with-out-stream stream (lisp-stream-sout string start end)))
- (funcall (lisp-stream-out stream) stream #\newline))
- (t ; Fundamental-stream.
- (stream-write-string stream string start end)
- (stream-write-char stream #\Newline)))
- string))
+ &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)
(defun charpos (&optional (stream *standard-output*))
- (with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column)))
+ (with-out-stream stream (ansi-stream-misc :charpos) (stream-line-column)))
(defun line-length (&optional (stream *standard-output*))
- (with-out-stream stream (lisp-stream-misc :line-length)
+ (with-out-stream stream (ansi-stream-misc :line-length)
(stream-line-length)))
(defun finish-output (&optional (stream *standard-output*))
- (with-out-stream stream (lisp-stream-misc :finish-output)
+ (with-out-stream stream (ansi-stream-misc :finish-output)
(stream-finish-output))
nil)
(defun force-output (&optional (stream *standard-output*))
- (with-out-stream stream (lisp-stream-misc :force-output)
+ (with-out-stream stream (ansi-stream-misc :force-output)
(stream-force-output))
nil)
(defun clear-output (&optional (stream *standard-output*))
- (with-out-stream stream (lisp-stream-misc :clear-output)
+ (with-out-stream stream (ansi-stream-misc :clear-output)
(stream-force-output))
nil)
(defun write-byte (integer stream)
- (with-out-stream stream (lisp-stream-bout integer)
+ (with-out-stream stream (ansi-stream-bout integer)
(stream-write-byte integer))
integer)
\f
-;;; This is called from lisp-steam routines that encapsulate CLOS
+;;; This is called from ANSI-STREAM routines that encapsulate CLOS
;;; streams to handle the misc routines and dispatch to the
;;; appropriate Gray stream functions.
(defun stream-misc-dispatch (stream operation &optional arg1 arg2)
(ignore arg2))
(case operation
(:listen
- ;; Return true if input available, :EOF for end-of-file, otherwise NIL.
+ ;; Return T if input available, :EOF for end-of-file, otherwise NIL.
(let ((char (stream-read-char-no-hang stream)))
(when (characterp char)
(stream-unread-char stream char))
\f
;;;; broadcast streams
-(defstruct (broadcast-stream (:include lisp-stream
+(defstruct (broadcast-stream (:include ansi-stream
(out #'broadcast-out)
(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)
(macrolet ((out-fun (fun method stream-method &rest args)
`(defun ,fun (stream ,@args)
(dolist (stream (broadcast-stream-streams stream))
- (if (lisp-stream-p stream)
+ (if (ansi-stream-p stream)
(funcall (,method stream) stream ,@args)
(,stream-method stream ,@args))))))
- (out-fun broadcast-out lisp-stream-out stream-write-char char)
- (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
- (out-fun broadcast-sout lisp-stream-sout stream-write-string
+ (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))
(defun broadcast-misc (stream operation &optional arg1 arg2)
(let ((res nil))
(dolist (stream streams res)
(setq res
- (if (lisp-stream-p stream)
- (funcall (lisp-stream-misc stream) stream operation
+ (if (ansi-stream-p stream)
+ (funcall (ansi-stream-misc stream) stream operation
arg1 arg2)
(stream-misc-dispatch stream operation arg1 arg2)))))))))
\f
;;;; synonym streams
-(defstruct (synonym-stream (:include lisp-stream
+(defstruct (synonym-stream (:include ansi-stream
(in #'synonym-in)
(bin #'synonym-bin)
(n-bin #'synonym-n-bin)
`(defun ,name (stream ,@args)
(declare (optimize (safety 1)))
(let ((syn (symbol-value (synonym-stream-symbol stream))))
- (if (lisp-stream-p syn)
+ (if (ansi-stream-p syn)
(funcall (,slot syn) syn ,@args)
(,stream-method syn ,@args))))))
- (out-fun synonym-out lisp-stream-out stream-write-char ch)
- (out-fun synonym-bout lisp-stream-bout stream-write-byte n)
- (out-fun synonym-sout lisp-stream-sout stream-write-string string start end))
+ (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))
;;; For the input methods, we just call the corresponding function on the
;;; synonymed stream. These functions deal with getting input out of
(in-fun synonym-bin read-byte eof-error-p eof-value)
(in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p))
-;;; We have to special-case the operations which could look at stuff in
-;;; the in-buffer.
(defun synonym-misc (stream operation &optional arg1 arg2)
(declare (optimize (safety 1)))
(let ((syn (symbol-value (synonym-stream-symbol stream))))
- (if (lisp-stream-p syn)
- (case operation
- (:listen (or (/= (the fixnum (lisp-stream-in-index syn))
- in-buffer-length)
- (funcall (lisp-stream-misc syn) syn :listen)))
+ (if (ansi-stream-p syn)
+ ;; We have to special-case some operations which interact with
+ ;; the in-buffer of the wrapped stream, since just calling
+ ;; ANSI-STREAM-MISC on them
+ (case operation
+ (:listen (or (/= (the fixnum (ansi-stream-in-index syn))
+ +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-misc syn) syn :listen)))
+ (:clear-input (clear-input syn))
+ (:unread (unread-char arg1 syn))
(t
- (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
+ (funcall (ansi-stream-misc syn) syn operation arg1 arg2)))
(stream-misc-dispatch syn operation arg1 arg2))))
\f
;;;; two-way streams
(defstruct (two-way-stream
- (:include lisp-stream
+ (:include ansi-stream
(in #'two-way-in)
(bin #'two-way-bin)
(n-bin #'two-way-n-bin)
(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 (required-argument) :type stream :read-only t)
- (output-stream (required-argument) :type stream :read-only t))
-(def!method print-object ((x two-way-stream) stream)
- (print-unreadable-object (x stream :type t :identity t)
- (format stream
- ":INPUT-STREAM ~S :OUTPUT-STREAM ~S"
- (two-way-stream-input-stream x)
- (two-way-stream-output-stream x))))
+ (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)
- "Returns 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
- "Returns 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.
(macrolet ((out-fun (name slot stream-method &rest args)
`(defun ,name (stream ,@args)
(let ((syn (two-way-stream-output-stream stream)))
- (if (lisp-stream-p syn)
+ (if (ansi-stream-p syn)
(funcall (,slot syn) syn ,@args)
(,stream-method syn ,@args))))))
- (out-fun two-way-out lisp-stream-out stream-write-char ch)
- (out-fun two-way-bout lisp-stream-bout stream-write-byte n)
- (out-fun two-way-sout lisp-stream-sout stream-write-string string start end))
+ (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))
(macrolet ((in-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(defun two-way-misc (stream operation &optional arg1 arg2)
(let* ((in (two-way-stream-input-stream stream))
(out (two-way-stream-output-stream stream))
- (in-lisp-stream-p (lisp-stream-p in))
- (out-lisp-stream-p (lisp-stream-p out)))
+ (in-ansi-stream-p (ansi-stream-p in))
+ (out-ansi-stream-p (ansi-stream-p out)))
(case operation
(:listen
- (if in-lisp-stream-p
- (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
- (funcall (lisp-stream-misc in) in :listen))
+ (if in-ansi-stream-p
+ (or (/= (the fixnum (ansi-stream-in-index in))
+ +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-misc in) in :listen))
(stream-listen in)))
((:finish-output :force-output :clear-output)
- (if out-lisp-stream-p
- (funcall (lisp-stream-misc out) out operation arg1 arg2)
+ (if out-ansi-stream-p
+ (funcall (ansi-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))
- ((:clear-input :unread)
- (if in-lisp-stream-p
- (funcall (lisp-stream-misc in) in operation arg1 arg2)
- (stream-misc-dispatch in operation arg1 arg2)))
+ (:clear-input (clear-input in))
+ (:unread (unread-char arg1 in))
(:element-type
(let ((in-type (stream-element-type in))
(out-type (stream-element-type out)))
(:close
(set-closed-flame stream))
(t
- (or (if in-lisp-stream-p
- (funcall (lisp-stream-misc in) in operation arg1 arg2)
+ (or (if in-ansi-stream-p
+ (funcall (ansi-stream-misc in) in operation arg1 arg2)
(stream-misc-dispatch in operation arg1 arg2))
- (if out-lisp-stream-p
- (funcall (lisp-stream-misc out) out operation arg1 arg2)
+ (if out-ansi-stream-p
+ (funcall (ansi-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))))))
\f
;;;; concatenated streams
(defstruct (concatenated-stream
- (:include lisp-stream
+ (:include ansi-stream
(in #'concatenated-in)
(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 stream we are reading from now.
+ ;; The car of this is the substream we are reading from now.
current
- ;; This is a list of all the streams. We need to remember them so that
- ;; we can close them.
+ ;; 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
":STREAMS ~S"
(concatenated-stream-streams x))))
-#!-high-security-support
-(setf (fdocumentation 'make-concatenated-stream 'function)
- "Returns 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
- "Returns 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)
(macrolet ((in-fun (name fun)
`(defun ,name (stream eof-error-p eof-value)
- (do ((current (concatenated-stream-current stream) (cdr current)))
+ (do ((current (concatenated-stream-current stream)
+ (cdr current)))
((null current)
(eof-or-lose stream eof-error-p eof-value))
(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))
+(defun concatenated-n-bin (stream buffer start numbytes eof-errorp)
+ (do ((current (concatenated-stream-current stream) (cdr current))
+ (current-start start)
+ (remaining-bytes numbytes))
+ ((null current)
+ (if eof-errorp
+ (error 'end-of-file :stream stream)
+ (- numbytes remaining-bytes)))
+ (let* ((stream (car current))
+ (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))))
+
(defun concatenated-misc (stream operation &optional arg1 arg2)
(let ((left (concatenated-stream-current stream)))
(when left
(case operation
(:listen
(loop
- (let ((stuff (if (lisp-stream-p current)
- (funcall (lisp-stream-misc current) current
+ (let ((stuff (if (ansi-stream-p current)
+ (funcall (ansi-stream-misc current) current
:listen)
(stream-misc-dispatch current :listen))))
(cond ((eq stuff :eof)
(t
;; Nothing is available yet.
(return nil))))))
- (:close
+ (:clear-input (clear-input current))
+ (:unread (unread-char arg1 current))
+ (:close
(set-closed-flame stream))
(t
- (if (lisp-stream-p current)
- (funcall (lisp-stream-misc current) current operation arg1 arg2)
+ (if (ansi-stream-p current)
+ (funcall (ansi-stream-misc current) current operation arg1 arg2)
(stream-misc-dispatch current operation arg1 arg2))))))))
\f
;;;; echo streams
(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))
(let* ((in (echo-stream-input-stream stream))
(out (echo-stream-output-stream stream))
(result (,fun in ,@args)))
- (if (lisp-stream-p out)
+ (if (ansi-stream-p out)
(funcall (,out-slot out) out result)
(,stream-method out result))
result)))))
- (in-fun echo-in read-char lisp-stream-out stream-write-char
+ (in-fun echo-in read-char ansi-stream-out stream-write-char
eof-error-p eof-value)
- (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte
+ (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)
(case operation
(:listen
(or (not (null (echo-stream-unread-stuff stream)))
- (if (lisp-stream-p in)
- (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
- (funcall (lisp-stream-misc in) in :listen))
+ (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
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 (lisp-stream-p in)
- (funcall (lisp-stream-misc in) in operation arg1 arg2)
+ (or (if (ansi-stream-p in)
+ (funcall (ansi-stream-misc in) in operation arg1 arg2)
(stream-misc-dispatch in operation arg1 arg2))
- (if (lisp-stream-p out)
- (funcall (lisp-stream-misc out) out 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)
- "Returns 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 lisp-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))
(truly-the index (+ index copy)))
(sb!sys:without-gcing
(system-area-copy (vector-sap string)
- (* index sb!vm:byte-bits)
+ (* index sb!vm:n-byte-bits)
(if (typep buffer 'system-area-pointer)
buffer
(vector-sap buffer))
- (* start sb!vm:byte-bits)
- (* copy sb!vm:byte-bits))))
+ (* start sb!vm:n-byte-bits)
+ (* copy sb!vm:n-byte-bits))))
(if (and (> requested copy) eof-error-p)
(error 'end-of-file :stream stream)
copy)))
(:element-type 'base-char)))
(defun make-string-input-stream (string &optional
- (start 0) (end (length string)))
+ (start 0) end)
#!+sb-doc
- "Returns an input stream which will supply the characters of String between
- Start and End in order."
+ "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 lisp-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))
#!+sb-doc
(setf (fdocumentation 'make-string-output-stream 'function)
- "Returns an Output stream which will accumulate all output given it for
- the benefit of the function Get-Output-Stream-String.")
+ "Return an output stream which will accumulate all output given it for
+ the benefit of the function GET-OUTPUT-STREAM-STRING.")
(defun string-ouch (stream character)
(let ((current (string-output-stream-index stream))
;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as
;;; GET-OUTPUT-STREAM-STRING would return them.
(defun dump-output-stream-string (in-stream out-stream)
- (write-string* (string-output-stream-string in-stream) out-stream
- 0 (string-output-stream-index in-stream))
+ (%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))
\f
;;;; fill-pointer streams
;;; 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 lisp-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))
(let ((offset-current (+ start current)))
(declare (fixnum offset-current))
(if (= offset-current end)
- (let* ((new-length (* current 2))
+ (let* ((new-length (1+ (* current 2)))
(new-workspace (make-string new-length)))
(declare (simple-string new-workspace))
- (%primitive sb!c:byte-blt
- workspace
- start
- new-workspace
- 0
- current)
+ (%byte-blt workspace start
+ new-workspace 0 current)
(setf workspace new-workspace)
(setf offset-current current)
(set-array-header buffer workspace new-length
(let* ((new-length (+ (the fixnum (* current 2)) string-len))
(new-workspace (make-string new-length)))
(declare (simple-string new-workspace))
- (%primitive sb!c:byte-blt
- workspace
- dst-start
- new-workspace
- 0
- current)
+ (%byte-blt workspace dst-start
+ new-workspace 0 current)
(setf workspace new-workspace)
(setf offset-current current)
(setf offset-dst-end dst-end)
new-length
nil))
(setf (fill-pointer buffer) dst-end))
- (%primitive sb!c:byte-blt
- string
- start
- workspace
- offset-current
- offset-dst-end)))
+ (%byte-blt string start
+ workspace offset-current offset-dst-end)))
dst-end))
(defun fill-pointer-misc (stream operation &optional arg1 arg2)
\f
;;;; indenting streams
-(defstruct (indenting-stream (:include lisp-stream
+(defstruct (indenting-stream (:include ansi-stream
(out #'indenting-out)
(sout #'indenting-sout)
(misc #'indenting-misc))
#!+sb-doc
(setf (fdocumentation 'make-indenting-stream 'function)
- "Returns an output stream which indents its output by some amount.")
+ "Return an output stream which indents its output by some amount.")
-;;; Indenting-Indent writes the correct number of spaces needed to indent
-;;; output on the given Stream based on the specified Sub-Stream.
+;;; INDENTING-INDENT writes the correct number of spaces needed to indent
+;;; output on the given STREAM based on the specified SUB-STREAM.
(defmacro indenting-indent (stream sub-stream)
;; KLUDGE: bare magic number 60
`(do ((i 0 (+ i 60))
(indentation (indenting-stream-indentation ,stream)))
((>= i indentation))
- (write-string*
+ (%write-string
" "
- ,sub-stream 0 (min 60 (- indentation i)))))
+ ,sub-stream
+ 0
+ (min 60 (- indentation i)))))
-;;; Indenting-Out writes a character to an indenting stream.
+;;; INDENTING-OUT writes a character to an indenting stream.
(defun indenting-out (stream char)
(let ((sub-stream (indenting-stream-stream stream)))
(write-char char sub-stream)
(if (char= char #\newline)
(indenting-indent stream sub-stream))))
-;;; Indenting-Sout writes a string to an indenting stream.
-
+;;; INDENTING-SOUT writes a string to an indenting stream.
(defun indenting-sout (stream string start end)
(declare (simple-string string) (fixnum start end))
(do ((i start)
((= i end))
(let ((newline (position #\newline string :start i :end end)))
(cond (newline
- (write-string* string sub-stream i (1+ newline))
+ (%write-string string sub-stream i (1+ newline))
(indenting-indent stream sub-stream)
(setq i (+ newline 1)))
(t
- (write-string* string sub-stream i end)
+ (%write-string string sub-stream i end)
(setq i end))))))
-;;; Indenting-Misc just treats just the :Line-Length message differently.
-;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
-;;; the stream's indentation.
-
+;;; INDENTING-MISC just treats just the :LINE-LENGTH message
+;;; differently. INDENTING-CHARPOS says the charpos is the charpos of
+;;; the base stream minus the stream's indentation.
(defun indenting-misc (stream operation &optional arg1 arg2)
(let ((sub-stream (indenting-stream-stream stream)))
- (if (lisp-stream-p sub-stream)
- (let ((method (lisp-stream-misc sub-stream)))
+ (if (ansi-stream-p sub-stream)
+ (let ((method (ansi-stream-misc sub-stream)))
(case operation
(:line-length
(let ((line-length (funcall method sub-stream operation)))
(- charpos (indenting-stream-indentation stream)))))
(t
(funcall method sub-stream operation arg1 arg2))))
- ;; Fundamental-stream.
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(case operation
(:line-length
(let ((line-length (stream-line-length sub-stream)))
(declaim (maybe-inline read-char unread-char read-byte listen))
\f
-;;;; case frobbing streams, used by format ~(...~)
+;;;; case frobbing streams, used by FORMAT ~(...~)
(defstruct (case-frob-stream
- (:include lisp-stream
- (:misc #'case-frob-misc))
+ (:include ansi-stream
+ (misc #'case-frob-misc))
(:constructor %make-case-frob-stream (target out sout))
(:copier nil))
- (target (required-argument) :type stream))
+ (target (missing-arg) :type stream))
(defun make-case-frob-stream (target kind)
#!+sb-doc
- "Returns a stream that sends all output to the stream TARGET, but modifies
+ "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.
kind)
(values stream))
(if (case-frob-stream-p target)
- ;; If we are going to be writing to a stream that already does case
- ;; frobbing, why bother frobbing the case just so it can frob it
- ;; again?
+ ;; If we are going to be writing to a stream that already does
+ ;; case frobbing, why bother frobbing the case just so it can
+ ;; frob it again?
target
(multiple-value-bind (out sout)
(ecase kind
(:close)
(t
(let ((target (case-frob-stream-target stream)))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-misc target) target op arg1 arg2)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-misc target) target op arg1 arg2)
(stream-misc-dispatch target op arg1 arg2))))))
(defun case-frob-upcase-out (stream char)
(type base-char char))
(let ((target (case-frob-stream-target stream))
(char (char-upcase char)))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-out target) target char)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
(stream-write-char target char))))
(defun case-frob-upcase-sout (stream str start end)
(string-upcase str)
(nstring-upcase (subseq str start end))))
(string-len (- end start)))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-sout target) target string 0 string-len)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-sout target) target string 0 string-len)
(stream-write-string target string 0 string-len))))
(defun case-frob-downcase-out (stream char)
(type base-char char))
(let ((target (case-frob-stream-target stream))
(char (char-downcase char)))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-out target) target char)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
(stream-write-char target char))))
(defun case-frob-downcase-sout (stream str start end)
(string-downcase str)
(nstring-downcase (subseq str start end))))
(string-len (- end start)))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-sout target) target string 0 string-len)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-sout target) target string 0 string-len)
(stream-write-string target string 0 string-len))))
(defun case-frob-capitalize-out (stream char)
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-upcase char)))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-out target) target char)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
(stream-write-char target char)))
(setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-aux-sout))
(t
- (if (lisp-stream-p target)
- (funcall (lisp-stream-out target) target char)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
(stream-write-char target char))))))
(defun case-frob-capitalize-sout (stream str start end)
#'case-frob-capitalize-aux-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-aux-sout))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-sout target) target str 0 len)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
(defun case-frob-capitalize-aux-out (stream char)
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-downcase char)))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-out target) target char)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
(stream-write-char target char))))
(t
- (if (lisp-stream-p target)
- (funcall (lisp-stream-out target) target char)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
(stream-write-char target char))
(setf (case-frob-stream-out stream)
#'case-frob-capitalize-out)
#'case-frob-capitalize-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-sout))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-sout target) target str 0 len)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
(defun case-frob-capitalize-first-out (stream char)
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-upcase char)))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-out target) target char)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
(stream-write-char target char)))
(setf (case-frob-stream-out stream)
#'case-frob-downcase-out)
(setf (case-frob-stream-sout stream)
#'case-frob-downcase-sout))
(t
- (if (lisp-stream-p target)
- (funcall (lisp-stream-out target) target char)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
(stream-write-char target char))))))
(defun case-frob-capitalize-first-sout (stream str start end)
(setf (case-frob-stream-sout stream)
#'case-frob-downcase-sout)
(return))))
- (if (lisp-stream-p target)
- (funcall (lisp-stream-sout target) target str 0 len)
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
\f
-;;;; public interface from "EXTENSIONS" package
+;;;; READ-SEQUENCE
-(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)))
-
-;;; 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)
- #!+sb-doc
- "This takes a stream and waits for text or a command to appear on it. If
- text appears before a command, this returns nil, and otherwise it returns
- a command."
- (let ((cmdp (funcall (lisp-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
-(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
(type index start)
(type sequence-end end)
(values index))
- (let ((end (or end (length seq))))
+ (if (ansi-stream-p stream)
+ (ansi-stream-read-sequence seq stream start end)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (stream-read-sequence stream seq start end)))
+
+(defun ansi-stream-read-sequence (seq stream start %end)
+ (declare (type sequence seq)
+ (type ansi-stream stream)
+ (type index start)
+ (type sequence-end %end)
+ (values index))
+ (let ((end (or %end (length seq))))
(declare (type index end))
(etypecase seq
(list
(setf (first rem) el)))))
(vector
(with-array-data ((data seq) (offset-start start) (offset-end end))
- (typecase data
+ (typecase data
((or (simple-array (unsigned-byte 8) (*))
(simple-array (signed-byte 8) (*))
simple-string)
(when (eq el :eof)
(return (+ start (- i offset-start))))
(setf (aref data i) el)))))))))))
+\f
+;;;; WRITE-SEQUENCE
(defun write-sequence (seq stream &key (start 0) (end nil))
#!+sb-doc
(type index start)
(type sequence-end end)
(values sequence))
- (let ((end (or end (length seq))))
- (declare (type index start end))
+ (if (ansi-stream-p stream)
+ (ansi-stream-write-sequence seq stream start end)
+ ;; must be Gray-streams FUNDAMENTAL-STREAM
+ (stream-write-sequence stream seq start end)))
+
+(defun ansi-stream-write-sequence (seq stream start %end)
+ (declare (type sequence seq)
+ (type ansi-stream stream)
+ (type index start)
+ (type sequence-end %end)
+ (values sequence))
+ (let ((end (or %end (length seq))))
+ (declare (type index end))
(etypecase seq
(list
(let ((write-function
(type index i))
(funcall write-function (first rem) stream))))
(string
- (write-string* seq stream start end))
+ (%write-string seq stream start end))
(vector
(let ((write-function
(if (subtypep (stream-element-type stream) 'character)
((>= i end) seq)
(declare (type index i))
(funcall write-function (aref seq i) stream)))))))
+\f
+;;;; etc.
;;; (These were inline throughout this file, but that's not appropriate
;;; globally.)
projects / sbcl.git / blobdiff