X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=925daa75d798f4313118a9b0fd876ba36b02e7d6;hb=add57c72c932fbf70c8ba8297154936c908b410e;hp=63b3fa382f733ffd992d20450553a39d1b9880fe;hpb=c47519c9e63fd32a635943a84ec13d8a60d95f08;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 63b3fa3..925daa7 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -63,7 +63,6 @@ (defun ansi-stream-input-stream-p (stream) (declare (type ansi-stream stream)) - #!+high-security (when (synonym-stream-p stream) (setf stream (symbol-value (synonym-stream-symbol stream)))) @@ -85,7 +84,6 @@ (defun ansi-stream-output-stream-p (stream) (declare (type ansi-stream stream)) - #!+high-security (when (synonym-stream-p stream) (setf stream (symbol-value (synonym-stream-symbol stream)))) @@ -103,6 +101,7 @@ (declaim (inline ansi-stream-open-stream-p)) (defun ansi-stream-open-stream-p (stream) (declare (type ansi-stream stream)) + ;; CLHS 22.1.4 lets us not worry about synonym streams here. (not (eq (ansi-stream-in stream) #'closed-flame))) (defun open-stream-p (stream) @@ -466,7 +465,7 @@ (defun %write-string (string stream start end) (declare (type string string)) - (declare (type streamlike stream)) + (declare (type stream-designator stream)) (declare (type index start end)) (let ((stream (out-synonym-of stream))) (cond ((ansi-stream-p stream) @@ -581,10 +580,7 @@ (defun make-broadcast-stream (&rest streams) (dolist (stream streams) - (unless (or (and (synonym-stream-p stream) - (output-stream-p (symbol-value - (synonym-stream-symbol stream)))) - (output-stream-p stream)) + (unless (output-stream-p stream) (error 'type-error :datum stream :expected-type '(satisfies output-stream-p)))) @@ -601,8 +597,20 @@ (defun broadcast-misc (stream operation &optional arg1 arg2) (let ((streams (broadcast-stream-streams stream))) (case operation + ;; FIXME: This may not be the best place to note this, but I + ;; think the :CHARPOS protocol needs revision. Firstly, I think + ;; this is the last place where a NULL return value was possible + ;; (before adjusting it to be 0), so a bunch of conditionals IF + ;; CHARPOS can be removed; secondly, it is my belief that + ;; FD-STREAMS, when running FILE-POSITION, do not update the + ;; CHARPOS, and consequently there will be much wrongness. + ;; + ;; FIXME: see also TWO-WAY-STREAM treatment of :CHARPOS -- why + ;; is it testing the :charpos of an input stream? + ;; + ;; -- CSR, 2004-02-04 (:charpos - (dolist (stream streams) + (dolist (stream streams 0) (let ((charpos (charpos stream))) (if charpos (return charpos))))) (:line-length @@ -611,10 +619,26 @@ (let ((res (line-length stream))) (when res (setq min (if min (min res min) res))))))) (:element-type + #+nil ; old, arguably more logical, version (let (res) - (dolist (stream streams (if (> (length res) 1) `(and ,@res) res)) - (pushnew (stream-element-type stream) res :test #'equal)))) - (:close) + (dolist (stream streams (if (> (length res) 1) `(and ,@res) t)) + (pushnew (stream-element-type stream) res :test #'equal))) + ;; ANSI-specified version (under System Class BROADCAST-STREAM) + (let ((res t)) + (do ((streams streams (cdr streams))) + ((null streams) res) + (when (null (cdr streams)) + (setq res (stream-element-type (car streams))))))) + (:file-position + (if arg1 + (let ((res (or (eql arg1 :start) (eql arg1 0)))) + (dolist (stream streams res) + (setq res (file-position stream arg1)))) + (let ((res 0)) + (dolist (stream streams res) + (setq res (file-position stream)))))) + (:close + (set-closed-flame stream)) (t (let ((res nil)) (dolist (stream streams res) @@ -706,17 +730,11 @@ ;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream ;; should be encapsulated in a function, and used here and most of ;; the other places that SYNONYM-STREAM-P appears. - (unless (or (and (synonym-stream-p output-stream) - (output-stream-p (symbol-value - (synonym-stream-symbol output-stream)))) - (output-stream-p output-stream)) + (unless (output-stream-p output-stream) (error 'type-error :datum output-stream :expected-type '(satisfies output-stream-p))) - (unless (or (and (synonym-stream-p input-stream) - (input-stream-p (symbol-value - (synonym-stream-symbol input-stream)))) - (input-stream-p input-stream)) + (unless (input-stream-p input-stream) (error 'type-error :datum input-stream :expected-type '(satisfies input-stream-p))) @@ -779,20 +797,10 @@ (bin #'concatenated-bin) (n-bin #'concatenated-n-bin) (misc #'concatenated-misc)) - (:constructor %make-concatenated-stream - (&rest streams &aux (current streams))) + (:constructor %make-concatenated-stream (&rest streams)) (:copier nil)) ;; The car of this is the substream we are reading from now. - current - ;; 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 - ;; private member %STREAM (with CONCATENATED-STREAM-STREAMS a wrapper - ;; around it which discards closed files from the head of the list) - ;; or we need to update it as we run out of files. - (streams nil :type list :read-only t)) + (streams nil :type list)) (def!method print-object ((x concatenated-stream) stream) (print-unreadable-object (x stream :type t :identity t) (format stream @@ -804,10 +812,7 @@ "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) - (input-stream-p (symbol-value - (synonym-stream-symbol stream)))) - (input-stream-p stream)) + (unless (input-stream-p stream) (error 'type-error :datum stream :expected-type '(satisfies input-stream-p)))) @@ -815,66 +820,68 @@ (macrolet ((in-fun (name fun) `(defun ,name (stream eof-error-p eof-value) - (do ((current (concatenated-stream-current stream) - (cdr current))) - ((null current) + (do ((streams (concatenated-stream-streams stream) + (cdr streams))) + ((null streams) (eof-or-lose stream eof-error-p eof-value)) - (let* ((stream (car current)) + (let* ((stream (car streams)) (result (,fun stream nil nil))) (when result (return result))) - (pop (concatenated-stream-current stream)))))) + (pop (concatenated-stream-streams stream)))))) (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)) + (do ((streams (concatenated-stream-streams stream) (cdr streams)) (current-start start) (remaining-bytes numbytes)) - ((null current) + ((null streams) (if eof-errorp (error 'end-of-file :stream stream) (- numbytes remaining-bytes))) - (let* ((stream (car current)) + (let* ((stream (car streams)) (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)))) + (setf (concatenated-stream-streams stream) (cdr streams)))) (defun concatenated-misc (stream operation &optional arg1 arg2) - (let ((left (concatenated-stream-current stream))) - (when left - (let* ((current (car left))) - (case operation - (:listen - (loop - (let ((stuff (if (ansi-stream-p current) - (funcall (ansi-stream-misc current) current - :listen) - (stream-misc-dispatch current :listen)))) - (cond ((eq stuff :eof) - ;; Advance CURRENT, and try again. - (pop (concatenated-stream-current stream)) - (setf current - (car (concatenated-stream-current stream))) - (unless current - ;; No further streams. EOF. - (return :eof))) - (stuff - ;; Stuff's available. - (return t)) - (t - ;; Nothing is available yet. - (return nil)))))) - (:clear-input (clear-input current)) - (:unread (unread-char arg1 current)) - (:close - (set-closed-flame stream)) - (t - (if (ansi-stream-p current) - (funcall (ansi-stream-misc current) current operation arg1 arg2) - (stream-misc-dispatch current operation arg1 arg2)))))))) + (let* ((left (concatenated-stream-streams stream)) + (current (car left))) + (case operation + (:listen + (unless left + (return-from concatenated-misc :eof)) + (loop + (let ((stuff (if (ansi-stream-p current) + (funcall (ansi-stream-misc current) current + :listen) + (stream-misc-dispatch current :listen)))) + (cond ((eq stuff :eof) + ;; Advance STREAMS, and try again. + (pop (concatenated-stream-streams stream)) + (setf current + (car (concatenated-stream-streams stream))) + (unless current + ;; No further streams. EOF. + (return :eof))) + (stuff + ;; Stuff's available. + (return t)) + (t + ;; Nothing is available yet. + (return nil)))))) + (:clear-input (when left (clear-input current))) + (:unread (when left (unread-char arg1 current))) + (:close + (set-closed-flame stream)) + (t + (when left + (if (ansi-stream-p current) + (funcall (ansi-stream-misc current) current operation arg1 arg2) + (stream-misc-dispatch current operation arg1 arg2))))))) ;;;; echo streams @@ -883,7 +890,7 @@ (in #'echo-in) (bin #'echo-bin) (misc #'echo-misc) - (n-bin #'ill-bin)) + (n-bin #'echo-n-bin)) (:constructor %make-echo-stream (input-stream output-stream)) (:copier nil)) unread-stuff) @@ -899,17 +906,11 @@ "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." - (unless (or (and (synonym-stream-p output-stream) - (output-stream-p (symbol-value - (synonym-stream-symbol output-stream)))) - (output-stream-p output-stream)) + (unless (output-stream-p output-stream) (error 'type-error :datum output-stream :expected-type '(satisfies output-stream-p))) - (unless (or (and (synonym-stream-p input-stream) - (input-stream-p (symbol-value - (synonym-stream-symbol input-stream)))) - (input-stream-p input-stream)) + (unless (input-stream-p input-stream) (error 'type-error :datum input-stream :expected-type '(satisfies input-stream-p))) @@ -920,11 +921,44 @@ (or (pop (echo-stream-unread-stuff stream)) (let* ((in (echo-stream-input-stream stream)) (out (echo-stream-output-stream stream)) - (result (,in-fun in ,@args))) - (,out-fun result out) - result))))) + (result (if eof-error-p + (,in-fun in ,@args) + (,in-fun in nil in)))) + (cond + ((eql result in) eof-value) + (t (,out-fun result out) result))))))) (in-fun echo-in read-char write-char eof-error-p eof-value) (in-fun echo-bin read-byte write-byte eof-error-p eof-value)) + +(defun echo-n-bin (stream buffer start numbytes eof-error-p) + (let ((new-start start) + (read 0)) + (loop + (let ((thing (pop (echo-stream-unread-stuff stream)))) + (cond + (thing + (setf (aref buffer new-start) thing) + (incf new-start) + (incf read) + (when (= read numbytes) + (return-from echo-n-bin numbytes))) + (t (return nil))))) + (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer + new-start (- numbytes read) nil))) + (cond + ((not eof-error-p) + (write-sequence buffer (echo-stream-output-stream stream) + :start new-start :end (+ new-start bytes-read)) + (+ bytes-read read)) + ((> numbytes (+ read bytes-read)) + (write-sequence buffer (echo-stream-output-stream stream) + :start new-start :end (+ new-start bytes-read)) + (error 'end-of-file :stream stream)) + (t + (write-sequence buffer (echo-stream-output-stream stream) + :start new-start :end (+ new-start bytes-read)) + (aver (= numbytes (+ new-start bytes-read))) + numbytes))))) ;;;; base STRING-STREAM stuff @@ -1018,6 +1052,7 @@ ;; This is checked by FILE-LENGTH, so no need to do it here either. ;; (:file-length (length (string-input-stream-string stream))) (:unread (decf (string-input-stream-current stream))) + (:close (set-closed-flame stream)) (:listen (or (/= (the index (string-input-stream-current stream)) (the index (string-input-stream-end stream))) :eof)) @@ -1030,7 +1065,8 @@ (declare (type string string) (type index start) (type (or index null) end)) - (let ((end (%check-vector-sequence-bounds string start end))) + (let* ((string (coerce string '(simple-array character (*)))) + (end (%check-vector-sequence-bounds string start end))) (with-array-data ((string string) (start start) (end end)) (internal-make-string-input-stream string ;; now simple @@ -1128,6 +1164,7 @@ (subseq buffer 0 end)))) arg1)))) (string-output-stream-index stream))) + (:close (set-closed-flame stream)) (:charpos (do ((index (1- (the fixnum (string-output-stream-index stream))) (1- index)) @@ -1255,7 +1292,7 @@ dst-end)) (defun fill-pointer-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) + (declare (ignore arg2)) (case operation (:file-position (let ((buffer (fill-pointer-output-stream-string stream))) @@ -1421,7 +1458,8 @@ (defun case-frob-misc (stream op &optional arg1 arg2) (declare (type case-frob-stream stream)) (case op - (:close) + (:close + (set-closed-flame stream)) (t (let ((target (case-frob-stream-target stream))) (if (ansi-stream-p target) @@ -1659,11 +1697,8 @@ (simple-array (signed-byte 8) (*)) simple-string) (let* ((numbytes (- end start)) - (bytes-read (sb!sys:read-n-bytes stream - data - offset-start - numbytes - nil))) + (bytes-read (read-n-bytes stream data offset-start + numbytes nil))) (if (< bytes-read numbytes) (+ start bytes-read) end)))