(in-package "SB!IMPL")
-(file-comment
- "$Header$")
-
(deftype string-stream ()
'(or string-input-stream string-output-stream
fill-pointer-output-stream))
;;;
;;; 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
+;;; 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:
;;; 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
+;;; 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:
;;; :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.
+;;; :element-type - Return the type of element the stream deals with.
;;; :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-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?
;;;
;;;
;;; THE STREAM IN-BUFFER:
;;;
-;;; The In-Buffer in the stream holds characters or bytes that
+;;; 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
+;;; 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
+;;; 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
+;;; 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.
+;;; 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
+;;; 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
+;;; 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
(declare (type (or index (member nil :start :end)) position))
(cond
(position
- (setf (lisp-stream-in-index stream) in-buffer-length)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(funcall (lisp-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))))))))
+ (when res
+ (- res (- +in-buffer-length+ (lisp-stream-in-index stream))))))))
;;; declaration test functions
(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)
(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)
(t
(funcall (lisp-stream-misc stream) stream
:unread character))))
- ;; Fundamental-stream
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(stream-unread-char stream character)))
nil)
(t
(unread-char char stream)
char)))
- ;; Fundamental-stream.
+ ;; 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))
(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.
+ (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.
+ ;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
(stream-listen stream))))
(defun read-char-no-hang (&optional (stream *standard-input*)
(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.
+ ;; 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)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(funcall (lisp-stream-misc stream) stream :clear-input))
(t
(stream-clear-input 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)
(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)))
+ (num-buffered (- +in-buffer-length+ index)))
(declare (fixnum index num-buffered))
(cond
((not in-buffer)
(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)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(+ (funcall (lisp-stream-n-bin stream)
stream
buffer
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 +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)
stream
ibuf
- in-buffer-extra
- (- in-buffer-length in-buffer-extra)
+ +in-buffer-extra+
+ (- +in-buffer-length+ +in-buffer-extra+)
nil))
- (start (- in-buffer-length count)))
+ (start (- +in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
- (setf (lisp-stream-in-index stream) in-buffer-length)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(funcall (lisp-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 +in-buffer-extra+)
+ (bit-bash-copy ibuf (+ (* +in-buffer-extra+ sb!vm:byte-bits)
(* sb!vm:vector-data-offset
sb!vm:word-bits))
ibuf (+ (the index (* start sb!vm:byte-bits))
(setf (lisp-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
+ ibuf 0 +in-buffer-length+
nil))
- (start (- in-buffer-length count)))
+ (start (- +in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
- (setf (lisp-stream-in-index stream) in-buffer-length)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(funcall (lisp-stream-bin stream) stream eof-error-p eof-value))
(t
(unless (zerop start)
(when (/= (or (charpos stream) 1) 0)
(funcall (lisp-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
+ ;; 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
stream data offset-start offset-end))
(funcall (lisp-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*)
offset-end)))
(with-out-stream stream (lisp-stream-sout string start end)))
(funcall (lisp-stream-out stream) stream #\newline))
- (t ; Fundamental-stream.
+ (t ; must be Gray streams FUNDAMENTAL-STREAM
(stream-write-string stream string start end)
(stream-write-char stream #\Newline)))
string))
nil)
(defun write-byte (integer stream)
- (with-out-stream stream (lisp-stream-bout integer) (stream-write-byte))
+ (with-out-stream stream (lisp-stream-bout integer)
+ (stream-write-byte integer))
integer)
\f
-;;; Stream-misc-dispatch
-;;;
-;;; Called from lisp-steam routines that encapsulate CLOS streams to
-;;; handle the misc routines and dispatch to the appropriate Gray
-;;; stream functions.
+;;; This is called from LISP-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)
(declare (type fundamental-stream stream)
(ignore arg2))
(case operation
(:listen
- ;; Return true is input available, :eof for eof-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))
(:constructor #!-high-security-support
make-broadcast-stream
#!+high-security-support
- %make-broadcast-stream (&rest streams)))
- ;; This is a list of all the streams we broadcast to.
+ %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
(bout #'synonym-bout)
(sout #'synonym-sout)
(misc #'synonym-misc))
- (:constructor make-synonym-stream (symbol)))
+ (:constructor make-synonym-stream (symbol))
+ (:copier nil))
;; This is the symbol, the value of which is the stream we are synonym to.
(symbol nil :type symbol :read-only t))
(def!method print-object ((x synonym-stream) stream)
(if (lisp-stream-p syn)
(case operation
(:listen (or (/= (the fixnum (lisp-stream-in-index syn))
- in-buffer-length)
+ +in-buffer-length+)
(funcall (lisp-stream-misc syn) syn :listen)))
(t
(funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
(:constructor #!-high-security-support
make-two-way-stream
#!+high-security-support
- %make-two-way-stream (input-stream output-stream)))
+ %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)
(case operation
(:listen
(if in-lisp-stream-p
- (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
+ (or (/= (the fixnum (lisp-stream-in-index in)) +in-buffer-length+)
(funcall (lisp-stream-misc in) in :listen))
(stream-listen in)))
((:finish-output :force-output :clear-output)
(:constructor
#!-high-security-support make-concatenated-stream
#!+high-security-support %make-concatenated-stream
- (&rest streams &aux (current streams))))
+ (&rest streams &aux (current streams)))
+ (:copier nil))
;; The car of this is the stream we are reading from now.
current
;; This is a list of all the streams. We need to remember them so that
:listen)
(stream-misc-dispatch current :listen))))
(cond ((eq stuff :eof)
- ;; Advance current, and try again.
+ ;; Advance CURRENT, and try again.
(pop (concatenated-stream-current stream))
(setf current
(car (concatenated-stream-current stream)))
;; Stuff's available.
(return t))
(t
- ;; Nothing available yet.
+ ;; Nothing is available yet.
(return nil))))))
(:close
(set-closed-flame stream))
(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)
(print-unreadable-object (x stream :type t :identity t)
(: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)
+ (or (/= (the fixnum (lisp-stream-in-index in))
+ +in-buffer-length+)
(funcall (lisp-stream-misc in) in :listen))
(stream-misc-dispatch in :listen))))
(:unread (push arg1 (echo-stream-unread-stuff stream)))
(n-bin #'string-stream-read-n-bytes)
(misc #'string-in-misc))
(:constructor internal-make-string-input-stream
- (string current end)))
+ (string current end))
+ (:copier nil))
(string nil :type simple-string)
(current nil :type index)
(end nil :type index))
(out #'string-ouch)
(sout #'string-sout)
(misc #'string-out-misc))
- (:constructor make-string-output-stream ()))
+ (: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.
(return count))))
(:element-type 'base-char)))
+;;; 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)
- #!+sb-doc
- "Returns a string of all the characters sent to a stream made by
- Make-String-Output-Stream since the last call to this function."
(declare (type string-output-stream stream))
(let* ((length (string-output-stream-index stream))
(result (make-string length)))
(setf (string-output-stream-index stream) 0)
result))
+;;; 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)
- #!+sb-doc
- "Dumps the characters buffer up in the In-Stream to the Out-Stream as
- Get-Output-Stream-String would return them."
(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
-;;; Fill pointer string output streams are not explicitly mentioned in the CLM,
-;;; but they are required for the implementation of With-Output-To-String.
+;;; Fill pointer STRING-OUTPUT-STREAMs are not explicitly mentioned in
+;;; the CLM, but they are required for the implementation of
+;;; WITH-OUTPUT-TO-STRING.
(defstruct (fill-pointer-output-stream
(:include lisp-stream
(out #'fill-pointer-ouch)
(sout #'fill-pointer-sout)
(misc #'fill-pointer-misc))
- (:constructor make-fill-pointer-output-stream (string)))
- ;; The string we throw stuff in.
+ (:constructor make-fill-pointer-output-stream (string))
+ (:copier nil))
+ ;; the string we throw stuff in
string)
(defun fill-pointer-ouch (stream character)
(out #'indenting-out)
(sout #'indenting-sout)
(misc #'indenting-misc))
- (:constructor make-indenting-stream (stream)))
+ (:constructor make-indenting-stream (stream))
+ (:copier nil))
;; the stream we're based on
stream
;; how much we indent on each line
(setf (fdocumentation 'make-indenting-stream 'function)
"Returns 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))
" "
,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)
(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)
(- 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))
- (:constructor %make-case-frob-stream (target out sout)))
+ (:constructor %make-case-frob-stream (target out sout))
+ (:copier nil))
(target (required-argument) :type stream))
(defun make-case-frob-stream (target kind)
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
(funcall (lisp-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
\f
-;;;; public interface from "EXTENSIONS" package
+;;;; stream commands
(defstruct (stream-command (:constructor make-stream-command
- (name &optional args)))
+ (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.
+;;; 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.
+ ;; 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))
projects / sbcl.git / blobdiff