X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=6422eccad7d6fdd963d9208263f460d97faddc48;hb=2c6b90e36a7c0377cd79625eb6c94d580f98cb93;hp=f4438535208d16e09646998a52a866b9e5be8da4;hpb=143edab8d233c784cde14bce6c5165219ea84bf4;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index f443853..6422ecc 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -201,7 +201,7 @@ ;;;; 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)) @@ -214,25 +214,42 @@ (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 + "~@" + :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)) ;;;; input functions @@ -318,7 +335,7 @@ (stream *standard-input*) (eof-error-p t) eof-value recursive-p) - + (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) (if (lisp-stream-p stream) (let ((char (read-char stream eof-error-p eof-value))) @@ -366,7 +383,7 @@ (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) at)) + (eq (funcall (lisp-stream-misc stream) stream :listen) t)) ;; Fall through to Gray streams FUNDAMENTAL-STREAM case. (stream-listen stream)))) @@ -413,12 +430,13 @@ ;;; 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) @@ -541,7 +559,7 @@ ;; 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)))) @@ -797,21 +815,16 @@ (: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 @@ -890,16 +903,17 @@ (: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 @@ -935,7 +949,8 @@ (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)) @@ -945,6 +960,22 @@ (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