From 954902abeb19dac4f79f0a5b800eac45179b8d7c Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 18 Sep 2003 16:43:56 +0000 Subject: [PATCH] 0.8.3.77: Implement FILE-POSITION on string streams ... patch from Nikodemus Siivola sbcl-devel 2003-09-15 --- NEWS | 2 + src/code/stream.lisp | 129 +++++++++++++++++++++++++++++++--------------- tests/stream.pure.lisp | 132 +++++++++++++++++++++++++++++++++++++++++++++--- version.lisp-expr | 2 +- 4 files changed, 215 insertions(+), 50 deletions(-) diff --git a/NEWS b/NEWS index 233131f..ab18811 100644 --- a/NEWS +++ b/NEWS @@ -2058,6 +2058,8 @@ changes in sbcl-0.8.4 relative to sbcl-0.8.3: argument now works properly on the Alpha platform. * bug fix: floating point exception treatment on the Alpha platform is improved. + * bug fix: FILE-POSITION works much better on string input and output + streams. (thanks to Nikodemus Siivola) * fixed some bugs revealed by Paul Dietz' test suite: ** the RETURN clause in LOOP is now equivalent to DO (RETURN ...). ** ROUND and FROUND now give the right answer when given very diff --git a/src/code/stream.lisp b/src/code/stream.lisp index e3dbd91..fb7c242 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1088,35 +1088,32 @@ (bin #'string-binch) (n-bin #'string-stream-read-n-bytes) (misc #'string-in-misc) - (string (missing-arg) - :type (simple-array character (*)))) + (string (missing-arg) :type simple-string)) (:constructor internal-make-string-input-stream (string current end)) (:copier nil)) - (current nil :type index) - (end nil :type index)) + (current (missing-arg) :type index) + (end (missing-arg) :type index)) (defun string-inch (stream eof-error-p eof-value) + (declare (type string-input-stream stream)) (let ((string (string-input-stream-string stream)) (index (string-input-stream-current stream))) - (declare (type (simple-array character (*)) string) - (type fixnum index)) - (cond ((= index (the index (string-input-stream-end stream))) + (cond ((>= index (the index (string-input-stream-end stream))) (eof-or-lose stream eof-error-p eof-value)) (t (setf (string-input-stream-current stream) (1+ index)) - (aref string index))))) + (char string index))))) (defun string-binch (stream eof-error-p eof-value) + (declare (type string-input-stream stream)) (let ((string (string-input-stream-string stream)) (index (string-input-stream-current stream))) - (declare (type (simple-array character (*)) string) - (type index index)) - (cond ((= index (the index (string-input-stream-end stream))) + (cond ((>= index (the index (string-input-stream-end stream))) (eof-or-lose stream eof-error-p eof-value)) (t (setf (string-input-stream-current stream) (1+ index)) - (char-code (aref string index)))))) + (char-code (char string index)))))) (defun string-stream-read-n-bytes (stream buffer start requested eof-error-p) (declare (type string-input-stream stream) @@ -1125,8 +1122,7 @@ (index (string-input-stream-current stream)) (available (- (string-input-stream-end stream) index)) (copy (min available requested))) - (declare (type (simple-array character (*)) string) - (type index index available copy)) + (declare (type simple-string string)) (when (plusp copy) (setf (string-input-stream-current stream) (truly-the index (+ index copy))) @@ -1143,7 +1139,8 @@ copy))) (defun string-in-misc (stream operation &optional arg1 arg2) - (declare (ignore arg2)) + (declare (type string-input-stream stream) + (ignore arg2)) (case operation (:file-position (if arg1 @@ -1151,28 +1148,34 @@ (case arg1 (:start 0) (:end (string-input-stream-end stream)) + ;; We allow moving position beyond EOF. Errors happen + ;; on read, not move -- or the user may extend the + ;; input string. (t arg1))) (string-input-stream-current stream))) - (:file-length (length (string-input-stream-string stream))) + ;; According to ANSI: "Should signal an error of type type-error + ;; if stream is not a stream associated with a file." + ;; 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))) - (:listen (or (/= (the fixnum (string-input-stream-current stream)) - (the fixnum (string-input-stream-end stream))) + (:listen (or (/= (the index (string-input-stream-current stream)) + (the index (string-input-stream-end stream))) :eof)) - (:element-type 'base-char))) + (:element-type (array-element-type (string-input-stream-string stream))))) -(defun make-string-input-stream (string &optional - (start 0) end) +(defun make-string-input-stream (string &optional (start 0) end) #!+sb-doc "Return an input stream which will supply the characters of STRING between START and END in order." (declare (type string string) (type index start) (type (or index null) end)) - - (internal-make-string-input-stream - (coerce string 'simple-string) - start - (%check-vector-sequence-bounds string start end))) + (let ((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 + start + end)))) ;;;; STRING-OUTPUT-STREAM stuff @@ -1190,6 +1193,8 @@ (:copier nil)) ;; Index of the next location to use. (index 0 :type fixnum) + ;; Index cache for string-output-stream-last-index + (index-cache 0 :type fixnum) ;; Requested element type (element-type 'character)) @@ -1198,6 +1203,10 @@ "Return an output stream which will accumulate all output given it for the benefit of the function GET-OUTPUT-STREAM-STRING.") +(defun string-output-stream-last-index (stream) + (max (string-output-stream-index stream) + (string-output-stream-index-cache stream))) + (defun string-ouch (stream character) (let ((current (string-output-stream-index stream)) (workspace (string-output-stream-string stream))) @@ -1206,17 +1215,15 @@ (if (= current (the fixnum (length workspace))) (let ((new-workspace (make-string (* current 2)))) (replace new-workspace workspace) - (setf (aref new-workspace current) character) - (setf (string-output-stream-string stream) new-workspace)) + (setf (aref new-workspace current) character + (string-output-stream-string stream) new-workspace)) (setf (aref workspace current) character)) (setf (string-output-stream-index stream) (1+ current)))) (defun string-sout (stream string start end) (declare (type simple-string string) (type fixnum start end)) - (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) + (let* ((string (coerce string '(simple-array character (*)))) (current (string-output-stream-index stream)) (length (- end start)) (dst-end (+ length current)) @@ -1239,7 +1246,25 @@ (declare (ignore arg2)) (case operation (:file-position - (if (null arg1) + (if arg1 + (let ((end (string-output-stream-last-index stream))) + (setf (string-output-stream-index-cache stream) end + (string-output-stream-index stream) + (case arg1 + (:start 0) + (:end end) + (t + ;; We allow moving beyond the end of stream, + ;; implicitly extending the output stream. + (let ((buffer (string-output-stream-string stream))) + (when (> arg1 (length buffer)) + (setf (string-output-stream-string stream) + (make-string + arg1 :element-type (array-element-type buffer)) + (subseq (string-output-stream-string stream) + 0 end) + (subseq buffer 0 end)))) + arg1)))) (string-output-stream-index stream))) (:charpos (do ((index (1- (the fixnum (string-output-stream-index stream))) @@ -1251,13 +1276,13 @@ (type fixnum index count)) (if (char= (schar string index) #\newline) (return count)))) - (:element-type 'base-char))) + (:element-type (array-element-type (string-output-stream-string stream))))) ;;; Return a string of all the characters sent to a stream made by ;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function. (defun get-output-stream-string (stream) (declare (type string-output-stream stream)) - (let* ((length (string-output-stream-index stream)) + (let* ((length (string-output-stream-last-index stream)) (element-type (string-output-stream-element-type stream)) (result (case element-type @@ -1271,7 +1296,8 @@ (replace result (string-output-stream-string stream))) ((simple-array nil (*)) (replace result (string-output-stream-string stream)))) - (setf (string-output-stream-index stream) 0) + (setf (string-output-stream-index stream) 0 + (string-output-stream-index-cache stream) 0) result)) ;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as @@ -1280,8 +1306,9 @@ (%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)) + (string-output-stream-last-index in-stream)) + (setf (string-output-stream-index in-stream) 0 + (string-output-stream-index-cache in-stream) 0)) ;;;; fill-pointer streams @@ -1300,7 +1327,7 @@ (misc #'fill-pointer-misc) ;; a string with a fill pointer where we stuff ;; the stuff we write - (string (error "missing argument") + (string (missing-arg) :type string-with-fill-pointer :read-only t)) (:constructor make-fill-pointer-output-stream (string)) @@ -1321,8 +1348,8 @@ (declare (simple-string new-workspace)) (%byte-blt workspace start new-workspace 0 current) - (setf workspace new-workspace) - (setf offset-current 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)) @@ -1368,6 +1395,25 @@ (defun fill-pointer-misc (stream operation &optional arg1 arg2) (declare (ignore arg1 arg2)) (case operation + (:file-position + (let ((buffer (fill-pointer-output-stream-string stream))) + (if arg1 + (setf (fill-pointer buffer) + (case arg1 + (:start 0) + ;; Fill-pointer is always at fill-pointer we will + ;; make :END move to the end of the actual string. + (:end (array-total-size buffer)) + ;; We allow moving beyond the end of string if the + ;; string is adjustable. + (t (when (>= arg1 (array-total-size buffer)) + (if (adjustable-array-p buffer) + (adjust-array buffer arg1) + (error "Cannot move FILE-POSITION beyond the end ~ + of WITH-OUTPUT-TO-STRING stream ~ + constructed with non-adjustable string."))) + arg1))) + (fill-pointer buffer)))) (:charpos (let* ((buffer (fill-pointer-output-stream-string stream)) (current (fill-pointer buffer))) @@ -1378,7 +1424,8 @@ (if found (- end (the fixnum found)) current))))) - (:element-type 'base-char))) + (:element-type (array-element-type + (fill-pointer-output-stream-string stream))))) ;;;; indenting streams diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp index 4bf264c..127333b 100644 --- a/tests/stream.pure.lisp +++ b/tests/stream.pure.lisp @@ -91,17 +91,133 @@ ;;; Ideas? #+nil (assert (eq (interactive-stream-p *terminal-io*) t)) -;;; FILE-POSITION on string-input-streams should work, even with -;;; :START or :END new positions. -(let ((stream (make-string-input-stream "abc"))) - (assert (char= (read-char stream) #\a)) - (assert (= (file-position stream) 1)) - (assert (file-position stream 0)) +;;; MAKE-STRING-INPUT-STREAM +;;; +;;; * Observe FILE-POSITION :START and :END, and allow setting of +;;; FILE-POSITION beyond the end of string, signalling END-OF-FILE only +;;; on read. +(let* ((string (copy-seq "abc")) + (stream (make-string-input-stream string))) (assert (char= (read-char stream) #\a)) + (assert (= 1 (file-position stream))) (assert (file-position stream :start)) - (assert (char= (read-char stream) #\a)) + (assert (= 0 (file-position stream))) + (assert (file-position stream :end)) + (assert (= (length string) (file-position stream))) + (assert (file-position stream (1- (file-position stream)))) + (assert (char= (read-char stream) #\c)) + (assert (file-position stream (1- (file-position stream)))) + (assert (char= (read-char stream) #\c)) (assert (file-position stream :end)) - (assert (eq (read-char stream nil 'foo) 'foo))) + (let ((eof (cons nil nil))) + (assert (eq (read-char stream nil eof) eof))) + (assert (file-position stream 10)) + (multiple-value-bind (val cond) (ignore-errors (file-position stream -1)) + (assert (null val)) + (assert (typep cond 'error))) + (multiple-value-bind (val cond) (ignore-errors (read-char stream)) + (assert (null val)) + (assert (typep cond 'end-of-file)))) + +;;; MAKE-STRING-OUTPUT-STREAM +;;; +;;; * Observe FILE-POSITION :START and :END, and allow setting of +;;; FILE-POSITION to an arbitrary index. +;;; +;;; * END will always refer to the farthest position of stream so-far +;;; seen, and setting FILE-POSITION beyond the current END will extend +;;; the string/stream with uninitialized elements. +;;; +;;; * Rewinding the stream works with overwriting semantics. +;;; +(let ((stream (make-string-output-stream))) + (princ "abcd" stream) + (assert (= 4 (file-position stream))) + (assert (file-position stream :start)) + (assert (= 0 (file-position stream))) + (princ "0" stream) + (assert (= 1 (file-position stream))) + (file-position stream 2) + (assert (= 2 (file-position stream))) + (princ "2" stream) + (assert (file-position stream :end)) + (assert (= 4 (file-position stream))) + (assert (file-position stream 6)) + (assert (file-position stream 4)) + (assert (file-position stream :end)) + (assert (= 6 (file-position stream))) + (assert (file-position stream 4)) + (multiple-value-bind (val cond) (ignore-errors (file-position stream -1)) + (assert (null val)) + (assert (typep cond 'error))) + (princ "!!" stream) + (assert (equal "0b2d!!" (get-output-stream-string stream)))) + +;;; WITH-OUTPUT-TO-STRING (when provided with a string argument) +;;; +;;; * Observe FILE-POSITION :START and :END, and allow setting of +;;; FILE-POSITION to an arbitrary index. If the new position is beyond +;;; the end of string and the string is adjustable the string will be +;;; implicitly extended, otherwise an error will be signalled. The +;;; latter case is provided for in the code, but not currently +;;; excercised since SBCL fill-pointer arrays are always (currently) adjustable. +;;; +;;; * END will refer to the ARRAY-TOTAL-SIZE of string, not +;;; FILL-POINTER, since by definition the FILE-POSITION will always be +;;; a FILL-POINTER, so that would be of limited use. +;;; +;;; * Rewinding the stream works with owerwriting semantics. +;;; +#+nil (let ((str (make-array 0 + :element-type 'character + :adjustable nil + :fill-pointer t))) + (with-output-to-string (stream str) + (princ "abcd" stream) + (assert (= 4 (file-position stream))) + (assert (file-position stream :start)) + (assert (= 0 (file-position stream))) + (princ "0" stream) + (assert (= 1 (file-position stream))) + (file-position stream 2) + (assert (= 2 (file-position stream))) + (princ "2" stream) + (assert (file-position stream :end)) + (assert (= 4 (file-position stream))) + (multiple-value-bind (val cond) (ignore-errors (file-position stream -1)) + (assert (null val)) + (assert (typep cond 'error))) + (multiple-value-bind (val cond) (ignore-errors (file-position stream 6)) + (assert (null val)) + (assert (typep cond 'error))) + (assert (equal "0b2d" str)))) + +(let ((str (make-array 0 + :element-type 'character + :adjustable nil + :fill-pointer t))) + (with-output-to-string (stream str) + (princ "abcd" stream) + (assert (= 4 (file-position stream))) + (assert (file-position stream :start)) + (assert (= 0 (file-position stream))) + (princ "0" stream) + (assert (= 1 (file-position stream))) + (file-position stream 2) + (assert (= 2 (file-position stream))) + (princ "2" stream) + (assert (file-position stream :end)) + (assert (= 4 (file-position stream))) + (assert (file-position stream 6)) + (assert (file-position stream 4)) + (assert (file-position stream :end)) + (assert (= 6 (file-position stream))) + (assert (file-position stream 4)) + (multiple-value-bind (val cond) (ignore-errors (file-position stream -1)) + (assert (null val)) + (assert (typep cond 'error))) + (princ "!!" stream) + (assert (equal "0b2d!!" str)))) ;;; MAKE-STRING-OUTPUT-STREAM and WITH-OUTPUT-TO-STRING take an ;;; :ELEMENT-TYPE keyword argument diff --git a/version.lisp-expr b/version.lisp-expr index 141d973..37b4b01 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.3.76" +"0.8.3.77" -- 1.7.10.4