X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=969c5623f68a982c557c46f4ea26064cfa3cb500;hb=731d5dd65a7b94b5d49d1663d9b60c3a406ce38c;hp=51c191166eaefae66174db7a4bd9429a77236cd4;hpb=1f724b3d4ea331dd05ace51a27a033831d83c85d;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 51c1911..969c562 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -115,6 +115,9 @@ (defun stream-element-type (stream) (ansi-stream-element-type stream)) +(defun stream-external-format (stream) + (funcall (ansi-stream-misc stream) stream :external-format)) + (defun interactive-stream-p (stream) (declare (type stream stream)) (funcall (ansi-stream-misc stream) stream :interactive-p)) @@ -189,6 +192,7 @@ ;; 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 + :datum stream :expected-type '(satisfies stream-associated-with-file-p) :format-control "~@" @@ -200,8 +204,18 @@ ;; cause cross-compiler hangup. ;; ;; (declare (type (or file-stream synonym-stream) stream)) - (stream-must-be-associated-with-file stream) + ;; + ;; The description for FILE-LENGTH says that an error must be raised + ;; for streams not associated with files (which broadcast streams + ;; aren't according to the glossary). However, the behaviour of + ;; FILE-LENGTH for broadcast streams is explicitly described in the + ;; BROADCAST-STREAM entry. + (unless (typep stream 'broadcast-stream) + (stream-must-be-associated-with-file stream)) (funcall (ansi-stream-misc stream) stream :file-length)) + +(defun file-string-length (stream object) + (funcall (ansi-stream-misc stream) stream :file-string-length object)) ;;;; input functions @@ -298,8 +312,11 @@ (defun ansi-stream-listen (stream) (or (/= (the fixnum (ansi-stream-in-index stream)) +ansi-stream-in-buffer-length+) - ;; Test for T explicitly since misc methods return :EOF sometimes. - (eq (funcall (ansi-stream-misc stream) stream :listen) t))) + ;; Handle :EOF return from misc methods specially + (let ((result (funcall (ansi-stream-misc stream) stream :listen))) + (if (eq result :eof) + nil + result)))) (defun listen (&optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) @@ -391,13 +408,23 @@ numbytes eof-error-p)) ((<= numbytes num-buffered) + #+nil + (let ((copy-function (typecase buffer + ((simple-array * (*)) #'ub8-bash-copy) + (system-area-pointer #'copy-ub8-to-system-area)))) + (funcall copy-function in-buffer index buffer start numbytes)) (%byte-blt in-buffer index buffer start (+ start numbytes)) (setf (ansi-stream-in-index stream) (+ index numbytes)) numbytes) (t (let ((end (+ start num-buffered))) - (%byte-blt in-buffer index buffer start end) + #+nil + (let ((copy-function (typecase buffer + ((simple-array * (*)) #'ub8-bash-copy) + (system-area-pointer #'copy-ub8-to-system-area)))) + (funcall copy-function in-buffer index buffer start num-buffered)) + (%byte-blt in-buffer index buffer start end) (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) (+ (funcall (ansi-stream-n-bin stream) stream @@ -419,30 +446,34 @@ ;;; and hence must be an N-BIN method. (defun fast-read-char-refill (stream eof-error-p eof-value) (let* ((ibuf (ansi-stream-cin-buffer stream)) - (count (funcall (ansi-stream-n-bin stream) - stream - ibuf - +ansi-stream-in-buffer-extra+ - (- +ansi-stream-in-buffer-length+ - +ansi-stream-in-buffer-extra+) - nil)) - (start (- +ansi-stream-in-buffer-length+ count))) + (count (funcall (ansi-stream-n-bin stream) + stream + ibuf + +ansi-stream-in-buffer-extra+ + (- +ansi-stream-in-buffer-length+ + +ansi-stream-in-buffer-extra+) + nil)) + (start (- +ansi-stream-in-buffer-length+ count))) (declare (type index start count)) (cond ((zerop count) - (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-in stream) stream eof-error-p eof-value)) - (t - (when (/= start +ansi-stream-in-buffer-extra+) - (bit-bash-copy ibuf (+ (* +ansi-stream-in-buffer-extra+ - sb!vm:n-byte-bits) - (* sb!vm:vector-data-offset - sb!vm:n-word-bits)) - ibuf (+ (the index (* start sb!vm:n-byte-bits)) - (* sb!vm:vector-data-offset - sb!vm:n-word-bits)) - (* count sb!vm:n-byte-bits))) - (setf (ansi-stream-in-index stream) (1+ start)) - (aref ibuf start))))) + (setf (ansi-stream-in-index stream) + +ansi-stream-in-buffer-length+) + (funcall (ansi-stream-in stream) stream eof-error-p eof-value)) + (t + (when (/= start +ansi-stream-in-buffer-extra+) + (#.(let* ((n-character-array-bits + (sb!vm:saetp-n-bits + (find 'character + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-specifier))) + (bash-function (intern (format nil "UB~A-BASH-COPY" n-character-array-bits) + (find-package "SB!KERNEL")))) + bash-function) + ibuf +ansi-stream-in-buffer-extra+ + ibuf start + count)) + (setf (ansi-stream-in-index stream) (1+ start)) + (aref ibuf start))))) ;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to ;;; leave room for unreading. @@ -458,11 +489,9 @@ (funcall (ansi-stream-bin stream) stream eof-error-p eof-value)) (t (unless (zerop start) - (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:n-word-bits) - ibuf (+ (the index (* start sb!vm:n-byte-bits)) - (* sb!vm:vector-data-offset - sb!vm:n-word-bits)) - (* count sb!vm:n-byte-bits))) + (ub8-bash-copy ibuf 0 + ibuf start + count)) (setf (ansi-stream-in-index stream) (1+ start)) (aref ibuf start))))) @@ -602,6 +631,8 @@ (finish-output stream)) (:element-type (stream-element-type stream)) + (:stream-external-format + (stream-external-format stream)) (:interactive-p (interactive-stream-p stream)) (:line-length @@ -610,6 +641,8 @@ (charpos stream)) (:file-length (file-length stream)) + (:file-string-length + (file-string-length stream arg1)) (:file-position (file-position stream arg1)))) @@ -677,6 +710,15 @@ ((null streams) res) (when (null (cdr streams)) (setq res (stream-element-type (car streams))))))) + (:external-format + (let ((res :default)) + (dolist (stream streams res) + (setq res (stream-external-format stream))))) + (:file-length + (let ((last (last streams))) + (if last + (file-length (car last)) + 0))) (:file-position (if arg1 (let ((res (or (eql arg1 :start) (eql arg1 0)))) @@ -685,6 +727,10 @@ (let ((res 0)) (dolist (stream streams res) (setq res (file-position stream)))))) + (:file-string-length + (let ((res 1)) + (dolist (stream streams res) + (setq res (file-string-length stream arg1))))) (:close (set-closed-flame stream)) (t @@ -815,7 +861,7 @@ (or (/= (the fixnum (ansi-stream-in-index in)) +ansi-stream-in-buffer-length+) (funcall (ansi-stream-misc in) in :listen)) - (stream-listen in))) + (listen in))) ((:finish-output :force-output :clear-output) (if out-ansi-stream-p (funcall (ansi-stream-misc out) out operation arg1 arg2) @@ -1008,32 +1054,18 @@ (aver (= numbytes (+ new-start bytes-read))) numbytes))))) -;;;; base STRING-STREAM stuff - -(defstruct (string-stream - (:include ansi-stream) - (:constructor nil) - (:copier nil)) - ;; FIXME: This type declaration is true, and will probably continue - ;; to be true. However, note well the comments in DEFTRANSFORM - ;; REPLACE, implying that performance of REPLACE is somewhat - ;; critical to performance of string streams. If (VECTOR CHARACTER) - ;; ever becomes different from (VECTOR BASE-CHAR), the transform - ;; probably needs to be extended. - (string (missing-arg) :type (vector character))) - ;;;; STRING-INPUT-STREAM stuff (defstruct (string-input-stream - (:include string-stream + (:include ansi-stream (in #'string-inch) (bin #'ill-bin) - (n-bin #'string-stream-read-n-bytes) - (misc #'string-in-misc) - (string (missing-arg) :type simple-string)) + (n-bin #'ill-bin) + (misc #'string-in-misc)) (:constructor internal-make-string-input-stream (string current end)) (:copier nil)) + (string (missing-arg) :type simple-string) (current (missing-arg) :type index) (end (missing-arg) :type index)) @@ -1068,14 +1100,16 @@ (when (plusp copy) (setf (string-input-stream-current stream) (truly-the index (+ index copy))) + ;; FIXME: why are we VECTOR-SAP'ing things here? what's the point? + ;; and are there SB-UNICODE issues here as well? --njf, 2005-03-24 (sb!sys:without-gcing - (system-area-copy (vector-sap string) - (* index sb!vm:n-byte-bits) - (if (typep buffer 'system-area-pointer) - buffer - (vector-sap buffer)) - (* start sb!vm:n-byte-bits) - (* copy sb!vm:n-byte-bits)))) + (system-area-ub8-copy (vector-sap string) + index + (if (typep buffer 'system-area-pointer) + buffer + (vector-sap buffer)) + start + copy))) (if (and (> requested copy) eof-error-p) (error 'end-of-file :stream stream) copy))) @@ -1124,17 +1158,16 @@ ;;;; STRING-OUTPUT-STREAM stuff (defstruct (string-output-stream - (:include string-stream + (:include ansi-stream (out #'string-ouch) (sout #'string-sout) - (misc #'string-out-misc) - ;; The string we throw stuff in. - (string (missing-arg) - :type (simple-array character (*)))) + (misc #'string-out-misc)) (:constructor make-string-output-stream (&key (element-type 'character) &aux (string (make-string 40)))) (:copier nil)) + ;; The string we throw stuff in. + (string (missing-arg) :type (simple-array character (*))) ;; Index of the next location to use. (index 0 :type fixnum) ;; Index cache for string-output-stream-last-index @@ -1233,14 +1266,19 @@ (element-type (string-output-stream-element-type stream)) (result (case element-type - ;; Overwhelmingly common case; can be inlined. + ;; overwhelmingly common case: can be inlined ((character) (make-string length)) + ;; slightly less common cases: inline it anyway + ((base-char standard-char) + (make-string length :element-type 'base-char)) (t (make-string length :element-type element-type))))) ;; For the benefit of the REPLACE transform, let's do this, so ;; that the common case isn't ludicrously expensive. (etypecase result ((simple-array character (*)) (replace result (string-output-stream-string stream))) + (simple-base-string + (replace result (string-output-stream-string stream))) ((simple-array nil (*)) (replace result (string-output-stream-string stream)))) (setf (string-output-stream-index stream) 0 @@ -1263,22 +1301,21 @@ ;;; 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. (deftype string-with-fill-pointer () '(and (vector character) (satisfies array-has-fill-pointer-p))) (defstruct (fill-pointer-output-stream - (:include string-stream + (:include ansi-stream (out #'fill-pointer-ouch) (sout #'fill-pointer-sout) - (misc #'fill-pointer-misc) - ;; a string with a fill pointer where we stuff - ;; the stuff we write - (string (missing-arg) - :type string-with-fill-pointer - :read-only t)) + (misc #'fill-pointer-misc)) (:constructor make-fill-pointer-output-stream (string)) - (:copier nil))) + (:copier nil)) + ;; a string with a fill pointer where we stuff the stuff we write + (string (missing-arg) :type string-with-fill-pointer :read-only t)) (defun fill-pointer-ouch (stream character) (let* ((buffer (fill-pointer-output-stream-string stream)) @@ -1292,9 +1329,9 @@ (if (= offset-current end) (let* ((new-length (1+ (* current 2))) (new-workspace (make-string new-length))) - (declare (simple-string new-workspace)) - (%byte-blt workspace start - new-workspace 0 current) + (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 @@ -1322,21 +1359,16 @@ (let* ((new-length (+ (the fixnum (* current 2)) string-len)) (new-workspace (make-string new-length))) (declare (type (simple-array character (*)) new-workspace)) - (%byte-blt workspace dst-start - new-workspace 0 current) - (setf workspace new-workspace) - (setf offset-current current) - (setf offset-dst-end dst-end) - (set-array-header buffer - workspace - new-length - dst-end - 0 - new-length - nil)) + (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)) - (%byte-blt string start - workspace offset-current offset-dst-end))) + (replace workspace string + :start1 offset-current :start2 start :end2 end))) dst-end)) (defun fill-pointer-misc (stream operation &optional arg1 arg2) @@ -1516,7 +1548,7 @@ (defun case-frob-upcase-out (stream char) (declare (type case-frob-stream stream) - (type base-char char)) + (type character char)) (let ((target (case-frob-stream-target stream)) (char (char-upcase char))) (if (ansi-stream-p target) @@ -1525,7 +1557,7 @@ (defun case-frob-upcase-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1541,7 +1573,7 @@ (defun case-frob-downcase-out (stream char) (declare (type case-frob-stream stream) - (type base-char char)) + (type character char)) (let ((target (case-frob-stream-target stream)) (char (char-downcase char))) (if (ansi-stream-p target) @@ -1550,7 +1582,7 @@ (defun case-frob-downcase-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1566,7 +1598,7 @@ (defun case-frob-capitalize-out (stream char) (declare (type case-frob-stream stream) - (type base-char char)) + (type character char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) (let ((char (char-upcase char))) @@ -1583,7 +1615,7 @@ (defun case-frob-capitalize-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1610,7 +1642,7 @@ (defun case-frob-capitalize-aux-out (stream char) (declare (type case-frob-stream stream) - (type base-char char)) + (type character char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) (let ((char (char-downcase char))) @@ -1628,7 +1660,7 @@ (defun case-frob-capitalize-aux-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1655,7 +1687,7 @@ (defun case-frob-capitalize-first-out (stream char) (declare (type case-frob-stream stream) - (type base-char char)) + (type character char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) (let ((char (char-upcase char))) @@ -1673,7 +1705,7 @@ (defun case-frob-capitalize-first-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1789,30 +1821,36 @@ (list (let ((write-function (if (subtypep (stream-element-type stream) 'character) - ;; FIXME (rudi 2004-08-09): since we know we're an - ;; ansi stream here, we could replace these - ;; functions with ansi-stream-specific constructs - #'write-char - #'write-byte))) + (ansi-stream-out stream) + (ansi-stream-bout stream)))) (do ((rem (nthcdr start seq) (rest rem)) (i start (1+ i))) - ((or (endp rem) (>= i end)) seq) + ((or (endp rem) (>= i end))) (declare (type list rem) (type index i)) - (funcall write-function (first rem) stream)))) + (funcall write-function stream (first rem))))) (string (%write-string seq stream start end)) (vector - (let ((write-function - (if (subtypep (stream-element-type stream) 'character) - ;; FIXME (rudi 2004-08-09): since we know we're an - ;; ansi stream here, we could replace these - ;; functions with ansi-specific constructs - #'write-char - #'write-byte))) - (do ((i start (1+ i))) - ((>= i end) seq) - (declare (type index i)) - (funcall write-function (aref seq i) stream))))))) + (with-array-data ((data seq) (offset-start start) (offset-end end)) + (labels + ((output-seq-in-loop () + (let ((write-function + (if (subtypep (stream-element-type stream) 'character) + (ansi-stream-out stream) + (ansi-stream-bout stream)))) + (do ((i offset-start (1+ i))) + ((>= i offset-end)) + (declare (type index i)) + (funcall write-function stream (aref data i)))))) + (typecase data + ((or (simple-array (unsigned-byte 8) (*)) + (simple-array (signed-byte 8) (*))) + (if (fd-stream-p stream) + (output-raw-bytes stream data offset-start offset-end) + (output-seq-in-loop))) + (t + (output-seq-in-loop)))))))) + seq) ;;;; etc.