X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=2bc1aa71a87620ca654c9b71c5fba5d45be2d86f;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=eb40f586401d127a418f48c475fbd528c1193c24;hpb=5d5894082c39ca44da75d38859d669c7b2108f6a;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index eb40f58..2bc1aa7 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -133,12 +133,9 @@ (setf (ansi-stream-sout stream) #'closed-flame) (setf (ansi-stream-misc stream) #'closed-flame)) -;;;; file position and file length +;;;; for file position and file length (defun external-format-char-size (external-format) - (let ((ef-entry (find-external-format external-format))) - (if (variable-width-external-format-p ef-entry) - (bytes-for-char-fun ef-entry) - (funcall (bytes-for-char-fun ef-entry) #\x)))) + (ef-char-size (get-external-format external-format))) ;;; Call the MISC method with the :FILE-POSITION operation. #!-sb-fluid (declaim (inline ansi-stream-file-position)) @@ -146,7 +143,7 @@ (declare (type stream stream)) (declare (type (or index (alien sb!unix:off-t) (member nil :start :end)) position)) - ;; FIXME: It woud be good to comment on the stuff that is done here... + ;; FIXME: It would be good to comment on the stuff that is done here... ;; FIXME: This doesn't look interrupt safe. (cond (position @@ -444,10 +441,8 @@ ;; a-s-read-sequence and needs a lambda list that's congruent with ;; that of a-s-read-char (declare (ignore recursive-p)) - (prepare-for-fast-read-byte stream - (prog1 - (fast-read-byte eof-error-p eof-value t) - (done-with-fast-read-byte)))) + (with-fast-read-byte (t stream eof-error-p eof-value) + (fast-read-byte))) (defun read-byte (stream &optional (eof-error-p t) eof-value) (if (ansi-stream-p stream) @@ -548,22 +543,27 @@ ;; An empty count does not necessarily mean that we reached ;; the EOF, it's also possible that it's e.g. due to a ;; invalid octet sequence in a multibyte stream. To handle - ;; the resyncing case correctly we need to call the - ;; single-character reading function and check whether an - ;; EOF was really reached. If not, we can just fill the - ;; buffer by one character, and hope that the next refill - ;; will not need to resync. - (let* ((value (funcall (ansi-stream-in stream) stream nil :eof)) - (index (1- +ansi-stream-in-buffer-length+))) - (case value - ((:eof) - ;; Mark buffer as empty. + ;; the resyncing case correctly we need to call the reading + ;; function and check whether an EOF was really reached. If + ;; not, we can just fill the buffer by one character, and + ;; hope that the next refill will not need to resync. + ;; + ;; KLUDGE: we can't use FD-STREAM functions (which are the + ;; only ones which will give us decoding errors) here, + ;; because this code is generic. We can't call the N-BIN + ;; function, because near the end of a real file that can + ;; legitimately bounce us to the IN function. So we have + ;; to call ANSI-STREAM-IN. + (let* ((index (1- +ansi-stream-in-buffer-length+)) + (value (funcall (ansi-stream-in stream) stream nil :eof))) + (cond + ((eql value :eof) + ;; definitely EOF now (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) - ;; EOF. Redo the read, this time with the real eof parameters. - (values t (funcall (ansi-stream-in stream) - stream eof-error-p eof-value))) - (otherwise + (values t (eof-or-lose stream eof-error-p eof-value))) + ;; we resynced or were given something instead + (t (setf (aref ibuf index) value) (values nil (setf (ansi-stream-in-index stream) index)))))) (t @@ -626,57 +626,46 @@ ;; must be Gray streams FUNDAMENTAL-STREAM (stream-fresh-line stream)))) -(defun write-string (string &optional (stream *standard-output*) - &key (start 0) end) - (declare (type string string)) - ;; 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]), - ;; (LENGTH STRING) is the required upper bound. A foolish - ;; consistency is the hobgoblin of lesser languages.. - (%write-string string stream start (%check-vector-sequence-bounds - string start end)) - string) - #!-sb-fluid (declaim (inline ansi-stream-write-string)) (defun ansi-stream-write-string (string stream start end) - (declare (type string string)) - (declare (type ansi-stream stream)) - (declare (type index start end)) (with-array-data ((data string) (offset-start start) (offset-end end) :check-fill-pointer t) (funcall (ansi-stream-sout stream) - stream data offset-start offset-end)) - string) + stream data offset-start offset-end))) (defun %write-string (string stream start end) + (let ((stream (out-synonym-of stream))) + (if (ansi-stream-p stream) + (ansi-stream-write-string string stream start end) + ;; must be Gray streams FUNDAMENTAL-STREAM + (stream-write-string stream string start end))) + string) + +(defun write-string (string &optional (stream *standard-output*) + &key (start 0) end) (declare (type string string)) (declare (type stream-designator stream)) - (declare (type index start end)) - (let ((stream (out-synonym-of stream))) - (if(ansi-stream-p stream) - (ansi-stream-write-string string stream start end) - ;; must be Gray streams FUNDAMENTAL-STREAM - (stream-write-string stream string start end)))) + (%write-string string stream start end)) ;;; A wrapper function for all those (MACROLET OUT-FUN) definitions, -;;; which cannot deal with keyword arguments. +;;; which cannot deal with keyword arguments. %WRITE-STRING cannot +;;; replace this, as this needs to deal with simple-strings as well. (declaim (inline write-string-no-key)) (defun write-string-no-key (string stream start end) (write-string string stream :start start :end end)) (defun write-line (string &optional (stream *standard-output*) - &key (start 0) end) + &key (start 0) end) (declare (type string string)) - ;; FIXME: Why is there this difference between the treatments of the - ;; STREAM argument in WRITE-STRING and WRITE-LINE? - (let ((defaulted-stream (out-synonym-of stream))) - (%write-string string defaulted-stream start (%check-vector-sequence-bounds - string start end)) - (write-char #\newline defaulted-stream)) + (declare (type stream-designator stream)) + (let ((stream (out-synonym-of stream))) + (cond ((ansi-stream-p stream) + (ansi-stream-write-string string stream start end) + (funcall (ansi-stream-out stream) stream #\newline)) + (t + (stream-write-string stream string start end) + (stream-write-char stream #\newline)))) string) (defun charpos (&optional (stream *standard-output*)) @@ -698,7 +687,7 @@ (defun clear-output (&optional (stream *standard-output*)) (with-out-stream stream (ansi-stream-misc :clear-output) - (stream-force-output)) + (stream-clear-output)) nil) (defun write-byte (integer stream) @@ -950,7 +939,6 @@ (macrolet ((in-fun (name fun &rest args) `(defun ,name (stream ,@args) - (force-output (two-way-stream-output-stream stream)) (,fun (two-way-stream-input-stream stream) ,@args)))) (in-fun two-way-in read-char eof-error-p eof-value) (in-fun two-way-bin read-byte eof-error-p eof-value) @@ -1093,7 +1081,7 @@ (n-bin #'echo-n-bin)) (:constructor %make-echo-stream (input-stream output-stream)) (:copier nil)) - unread-stuff) + (unread-stuff nil :type boolean)) (def!method print-object ((x echo-stream) stream) (print-unreadable-object (x stream :type t :identity t) (format stream @@ -1118,47 +1106,55 @@ (macrolet ((in-fun (name in-fun out-fun &rest args) `(defun ,name (stream ,@args) - (or (pop (echo-stream-unread-stuff stream)) - (let* ((in (echo-stream-input-stream stream)) - (out (echo-stream-output-stream stream)) - (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))))))) + (let* ((unread-stuff-p (echo-stream-unread-stuff stream)) + (in (echo-stream-input-stream stream)) + (out (echo-stream-output-stream stream)) + (result (if eof-error-p + (,in-fun in ,@args) + (,in-fun in nil in)))) + (setf (echo-stream-unread-stuff stream) nil) + (cond + ((eql result in) eof-value) + ;; If unread-stuff was true, the character read + ;; from the input stream was previously echoed. + (t (unless unread-stuff-p (,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))))) + (let ((bytes-read 0)) + ;; Note: before ca 1.0.27.18, the logic for handling unread + ;; characters never could have worked, so probably nobody has ever + ;; tried doing bivalent block I/O through an echo stream; this may + ;; not work either. + (when (echo-stream-unread-stuff stream) + (let* ((char (read-char stream)) + (octets (string-to-octets + (string char) + :external-format + (stream-external-format + (echo-stream-input-stream stream)))) + (octet-count (length octets)) + (blt-count (min octet-count numbytes))) + (replace buffer octets :start1 start :end1 (+ start blt-count)) + (incf start blt-count) + (decf numbytes blt-count))) + (incf bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer + start numbytes nil)) + (cond + ((not eof-error-p) + (write-sequence buffer (echo-stream-output-stream stream) + :start start :end (+ start bytes-read)) + bytes-read) + ((> numbytes bytes-read) + (write-sequence buffer (echo-stream-output-stream stream) + :start start :end (+ start bytes-read)) + (error 'end-of-file :stream stream)) + (t + (write-sequence buffer (echo-stream-output-stream stream) + :start start :end (+ start bytes-read)) + (aver (= numbytes (+ start bytes-read))) + numbytes)))) ;;;; STRING-INPUT-STREAM stuff @@ -1303,7 +1299,7 @@ ;; end of the stream. (index-cache 0 :type index) ;; Requested element type - (element-type 'character)) + (element-type 'character :type type-specifier)) #!+sb-doc (setf (fdocumentation 'make-string-output-stream 'function) @@ -1462,6 +1458,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (defun string-out-misc (stream operation &optional arg1 arg2) (declare (ignore arg2)) + (declare (optimize speed)) (case operation (:charpos ;; Keeping this first is a silly micro-optimization: FRESH-LINE @@ -1471,8 +1468,10 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (buffer (string-output-stream-buffer stream)) (prev (string-output-stream-prev stream)) (base 0)) + (declare (type (or null (simple-array character (*))) buffer)) :next - (let ((pos (position #\newline buffer :from-end t :end pointer))) + (let ((pos (when buffer + (position #\newline buffer :from-end t :end pointer)))) (when (or pos (not buffer)) ;; If newline is at index I, and pointer at index I+N, charpos ;; is N-1. If there is no newline, and pointer is at index N, @@ -1568,11 +1567,16 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") ;;; the CLM, but they are required for the implementation of ;;; WITH-OUTPUT-TO-STRING. -;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL), -;;; ideally without destroying all hope of efficiency. +;;; FIXME: need to support (VECTOR NIL), ideally without destroying all hope +;;; of efficiency. +(declaim (inline vector-with-fill-pointer)) +(defun vector-with-fill-pointer-p (x) + (and (vectorp x) + (array-has-fill-pointer-p x))) + (deftype string-with-fill-pointer () - '(and (vector character) - (satisfies array-has-fill-pointer-p))) + `(and (or (vector character) (vector base-char)) + (satisfies vector-with-fill-pointer-p))) (defstruct (fill-pointer-output-stream (:include ansi-stream @@ -1590,53 +1594,63 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (current+1 (1+ current))) (declare (fixnum current)) (with-array-data ((workspace buffer) (start) (end)) - (declare (type (simple-array character (*)) workspace)) - (let ((offset-current (+ start current))) - (declare (fixnum offset-current)) - (if (= offset-current end) - (let* ((new-length (1+ (* current 2))) - (new-workspace (make-string new-length))) - (declare (type (simple-array character (*)) new-workspace)) - (replace new-workspace workspace - :start2 start :end2 offset-current) - (setf workspace new-workspace - offset-current current) - (set-array-header buffer workspace new-length - current+1 0 new-length nil)) - (setf (fill-pointer buffer) current+1)) - (setf (schar workspace offset-current) character))) + (string-dispatch + ((simple-array character (*)) + (simple-array base-char (*))) + workspace + (let ((offset-current (+ start current))) + (declare (fixnum offset-current)) + (if (= offset-current end) + (let* ((new-length (1+ (* current 2))) + (new-workspace + (ecase (array-element-type workspace) + (character (make-string new-length + :element-type 'character)) + (base-char (make-string new-length + :element-type 'base-char))))) + (replace new-workspace workspace :start2 start :end2 offset-current) + (setf workspace new-workspace + offset-current current) + (set-array-header buffer workspace new-length + current+1 0 new-length nil nil)) + (setf (fill-pointer buffer) current+1)) + (setf (char workspace offset-current) character)))) current+1)) (defun fill-pointer-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer)) - (string-len (- end start)) - (dst-end (+ string-len current))) - (declare (fixnum current dst-end string-len)) - (with-array-data ((workspace buffer) (dst-start) (dst-length)) - (declare (type (simple-array character (*)) workspace)) - (let ((offset-dst-end (+ dst-start dst-end)) - (offset-current (+ dst-start current))) - (declare (fixnum offset-dst-end offset-current)) - (if (> offset-dst-end dst-length) - (let* ((new-length (+ (the fixnum (* current 2)) string-len)) - (new-workspace (make-string new-length))) - (declare (type (simple-array character (*)) new-workspace)) - (replace new-workspace workspace - :start2 dst-start :end2 offset-current) - (setf workspace new-workspace - offset-current current - offset-dst-end dst-end) - (set-array-header buffer workspace new-length - dst-end 0 new-length nil)) - (setf (fill-pointer buffer) dst-end)) - (replace workspace string - :start1 offset-current :start2 start :end2 end))) - dst-end)) + (declare (fixnum start end)) + (string-dispatch + ((simple-array character (*)) + (simple-array base-char (*))) + string + (let* ((buffer (fill-pointer-output-stream-string stream)) + (current (fill-pointer buffer)) + (string-len (- end start)) + (dst-end (+ string-len current))) + (declare (fixnum current dst-end string-len)) + (with-array-data ((workspace buffer) (dst-start) (dst-length)) + (let ((offset-dst-end (+ dst-start dst-end)) + (offset-current (+ dst-start current))) + (declare (fixnum offset-dst-end offset-current)) + (if (> offset-dst-end dst-length) + (let* ((new-length (+ (the fixnum (* current 2)) string-len)) + (new-workspace + (ecase (array-element-type workspace) + (character (make-string new-length + :element-type 'character)) + (base-char (make-string new-length + :element-type 'base-char))))) + (replace new-workspace workspace + :start2 dst-start :end2 offset-current) + (setf workspace new-workspace + offset-current current + offset-dst-end dst-end) + (set-array-header buffer workspace new-length + dst-end 0 new-length nil nil)) + (setf (fill-pointer buffer) dst-end)) + (replace workspace string + :start1 offset-current :start2 start :end2 end))) + dst-end))) (defun fill-pointer-misc (stream operation &optional arg1 arg2) (declare (ignore arg2)) @@ -1670,93 +1684,9 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (if found (- end (the fixnum found)) current))))) - (:element-type (array-element-type - (fill-pointer-output-stream-string stream))))) - -;;;; indenting streams - -(defstruct (indenting-stream (:include ansi-stream - (out #'indenting-out) - (sout #'indenting-sout) - (misc #'indenting-misc)) - (:constructor make-indenting-stream (stream)) - (:copier nil)) - ;; the stream we're based on - stream - ;; how much we indent on each line - (indentation 0)) - -#!+sb-doc -(setf (fdocumentation 'make-indenting-stream 'function) - "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. -(defmacro indenting-indent (stream sub-stream) - ;; KLUDGE: bare magic number 60 - `(do ((i 0 (+ i 60)) - (indentation (indenting-stream-indentation ,stream))) - ((>= i indentation)) - (%write-string - #.(make-string 60 :initial-element #\Space) - ,sub-stream - 0 - (min 60 (- indentation i))))) - -;;; INDENTING-OUT writes a character to an indenting stream. -(defun indenting-out (stream char) - (let ((sub-stream (indenting-stream-stream stream))) - (write-char char sub-stream) - (if (char= char #\newline) - (indenting-indent stream sub-stream)))) - -;;; INDENTING-SOUT writes a string to an indenting stream. -(defun indenting-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (do ((i start) - (sub-stream (indenting-stream-stream stream))) - ((= i end)) - (let ((newline (position #\newline string :start i :end end))) - (cond (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) - (setq i end)))))) - -;;; INDENTING-MISC just treats just the :LINE-LENGTH message -;;; differently. INDENTING-CHARPOS says the charpos is the charpos of -;;; the base stream minus the stream's indentation. -(defun indenting-misc (stream operation &optional arg1 arg2) - (let ((sub-stream (indenting-stream-stream stream))) - (if (ansi-stream-p sub-stream) - (let ((method (ansi-stream-misc sub-stream))) - (case operation - (:line-length - (let ((line-length (funcall method sub-stream operation))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let ((charpos (funcall method sub-stream operation))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - (funcall method sub-stream operation arg1 arg2)))) - ;; must be Gray streams FUNDAMENTAL-STREAM - (case operation - (:line-length - (let ((line-length (stream-line-length sub-stream))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let ((charpos (stream-line-column sub-stream))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - (stream-misc-dispatch sub-stream operation arg1 arg2)))))) - -(declaim (maybe-inline read-char unread-char read-byte listen)) + (:element-type + (array-element-type + (fill-pointer-output-stream-string stream))))) ;;;; case frobbing streams, used by FORMAT ~(...~) @@ -2117,14 +2047,14 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (refill-buffer)) (done-with-fast-read-char) (return-from ansi-stream-read-string-from-frc-buffer - read))))) + (+ start read)))))) (declare (inline refill-buffer)) (when (and (= %frc-index% +ansi-stream-in-buffer-length+) (refill-buffer)) ;; EOF had been reached before we read anything ;; at all. Return the EOF value or signal the error. (done-with-fast-read-char) - (return-from ansi-stream-read-string-from-frc-buffer 0)) + (return-from ansi-stream-read-string-from-frc-buffer start)) (loop (add-chunk))))))