(declare (type stream stream))
(funcall (lisp-stream-misc stream) stream :interactive-p))
-(defun open-stream-p (stream)
- (declare (type stream stream))
- (not (eq (lisp-stream-in stream) #'closed-flame)))
-
(defun close (stream &key abort)
(declare (type stream stream))
(when (open-stream-p stream)
\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))
(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.
+;;; 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-string
+ "~@<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")
-
+ (stream-must-be-associated-with-file stream)
(funcall (lisp-stream-misc stream) stream :file-length))
\f
;;;; input functions
(let ((index (1- (lisp-stream-in-index stream)))
(buffer (lisp-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))
(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)))
(unless (eq char eof-value)
(unread-char char stream))
char)))
- (t
+ ((null peek-type)
(unread-char char stream)
- char)))
- ;; must be Gray streams FUNDAMENTAL-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)))
+ (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))
(stream-unread-char stream char)
char)))))
((eq peek-type t)
- (do ((char (stream-read-char stream) (stream-read-char stream)))
+ (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
+ ((null peek-type)
(let ((char (stream-peek-char stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
- char)))))))
+ char)))
+ (t
+ (error "internal error: impossible case"))))))
(defun listen (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
numbytes
eof-error-p))
((<= numbytes num-buffered)
- (%primitive sb!c:byte-blt
- in-buffer
- index
- buffer
- start
- (+ start numbytes))
+ (%byte-blt in-buffer index
+ buffer start (+ start numbytes))
(setf (lisp-stream-in-index stream) (+ index numbytes))
numbytes)
(t
(let ((end (+ start num-buffered)))
- (%primitive sb!c:byte-blt in-buffer index buffer start end)
+ (%byte-blt in-buffer index buffer start end)
(setf (lisp-stream-in-index stream) +in-buffer-length+)
(+ (funcall (lisp-stream-n-bin stream)
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
- ;; (AVER (<= 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))
+ &key (start 0) (end nil))
+ (%write-string string stream start (or end (length string)))
+ string)
- (write-string* string stream start end))
+(defun %write-string (string stream start 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))
-(defun write-string* (string &optional (stream *standard-output*)
- (start 0) (end (length (the vector string))))
- (declare (fixnum start end))
(let ((stream (out-synonym-of stream)))
(cond ((lisp-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 (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 ; must be Gray streams FUNDAMENTAL-STREAM
- (stream-write-string stream string start end)
- (stream-write-char stream #\Newline)))
- string))
+ &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)
+ (write-char #\newline defaulted-stream))
+ string)
(defun charpos (&optional (stream *standard-output*))
(with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column)))
(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
+ ;; We have to special-case some operations which interact with
+ ;; the in-buffer of the wrapped stream, since just calling
+ ;; LISP-STREAM-MISC on them
+ (case operation
(:listen (or (/= (the fixnum (lisp-stream-in-index syn))
+in-buffer-length+)
(funcall (lisp-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)))
(stream-misc-dispatch syn operation arg1 arg2))))
(: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))))
+(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
+ "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
- "Returns a bidirectional stream which gets its input from Input-Stream and
+ "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
(if out-lisp-stream-p
(funcall (lisp-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)))
#!-high-security-support
(setf (fdocumentation 'make-concatenated-stream 'function)
- "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.")
#!+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)
(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)
#!+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
+ "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")
\f
;;;; string input streams
(defun make-string-input-stream (string &optional
(start 0) (end (length string)))
#!+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))
#!+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
(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)
#!+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.
`(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.
(defun indenting-out (stream char)
((= 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
(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.
(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)