X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=244425d297ea0d5637311716fa9785d5813d3b64;hb=416152f084604094445a758ff399871132dff2bd;hp=f4438535208d16e09646998a52a866b9e5be8da4;hpb=143edab8d233c784cde14bce6c5165219ea84bf4;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index f443853..244425d 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -179,10 +179,6 @@ (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) @@ -201,7 +197,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 +210,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 @@ -303,7 +316,7 @@ (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)) @@ -317,8 +330,20 @@ (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 "~@" + :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))) @@ -335,12 +360,15 @@ (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)) @@ -348,25 +376,28 @@ (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))) (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 +444,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) @@ -437,17 +469,13 @@ 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 @@ -534,33 +562,29 @@ (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)) + &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 "~@" + 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) @@ -574,25 +598,12 @@ (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))) @@ -765,16 +776,19 @@ (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)))) @@ -797,21 +811,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 @@ -865,10 +874,8 @@ (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))) @@ -890,16 +897,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 +943,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 +954,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 @@ -970,7 +995,9 @@ (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) @@ -1217,8 +1244,10 @@ ;;; 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)) ;;;; fill-pointer streams @@ -1247,15 +1276,11 @@ (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 @@ -1280,12 +1305,8 @@ (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) @@ -1297,12 +1318,8 @@ 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) @@ -1344,9 +1361,11 @@ `(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) @@ -1363,11 +1382,11 @@ ((= 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 @@ -1750,7 +1769,7 @@ (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)