X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=4611a72215f3a37f6fe8cfe1c738716e6ca1596c;hb=338732358d49ab202fe55c3581294597d63aec6b;hp=6ff6a911773d023c47ca4d9aabc7c613424476e8;hpb=771b864c8f32af7734bc0550aeaf1539fc4df194;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 6ff6a91..4611a72 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -276,11 +276,11 @@ #!-sb-fluid (declaim (inline ansi-stream-unread-char)) (defun ansi-stream-unread-char (character stream) (let ((index (1- (ansi-stream-in-index stream))) - (buffer (ansi-stream-in-buffer stream))) + (buffer (ansi-stream-cin-buffer stream))) (declare (fixnum index)) (when (minusp index) (error "nothing to unread")) (cond (buffer - (setf (aref buffer index) (char-code character)) + (setf (aref buffer index) character) (setf (ansi-stream-in-index stream) index)) (t (funcall (ansi-stream-misc stream) stream @@ -298,8 +298,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 +394,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 @@ -418,31 +431,35 @@ ;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER, ;;; and hence must be an N-BIN method. (defun fast-read-char-refill (stream eof-error-p eof-value) - (let* ((ibuf (ansi-stream-in-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))) + (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))) (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)) - (code-char (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 +475,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))))) @@ -815,7 +830,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 +1023,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 +1069,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 +1127,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 +1235,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 +1270,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 +1298,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 +1328,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 +1517,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 +1526,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 +1542,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 +1551,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 +1567,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 +1584,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 +1611,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 +1629,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 +1656,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 +1674,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)) @@ -1742,8 +1743,7 @@ (with-array-data ((data seq) (offset-start start) (offset-end end)) (typecase data ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*)) - simple-string) + (simple-array (signed-byte 8) (*))) (let* ((numbytes (- end start)) (bytes-read (read-n-bytes stream data offset-start numbytes nil)))