\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)))
;;; 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)
(type index numbytes start)
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
;; 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)))
+ ;; (AVER (<= 0 START END (LENGTH STRING)))
;; instead of modifying the incorrect values.
#!+high-security
(setf end (min end (length (the vector string))))
(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)))
(:include lisp-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)))
(: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
(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))
(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
(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)
(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)