0.8.3.77:

	Implement FILE-POSITION on string streams
	... patch from Nikodemus Siivola sbcl-devel 2003-09-15

diff --git a/NEWS b/NEWS
index 233131f..ab18811 100644 (file)
--- 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 (file)
--- 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))))
 \f
 ;;;; 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))
 \f
 ;;;; 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)))))
 \f
 ;;;; indenting streams
 

diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp
index 4bf264c..127333b 100644 (file)
--- 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 (file)
--- 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"