0.9.7.2:

	Merge "file-string-length" patch (Robert J. Macomber sbcl-devel
	2005-11-28)
	... write a test case or two.

diff --git a/NEWS b/NEWS
index 27c4edf..16ff77f 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,9 @@
 changes in sbcl-0.9.8 relative to sbcl-0.9.7:
   * fixed bug #391: complicated :TYPE intersections in slot
     definitions no longer cause an error in PCL internals.
+  * bug fix: FILE-STRING-LENGTH is now external-format sensitive,
+    returning the number of octets which would be written to the
+    file-stream.  (thanks to Robert J. Macomber)
 
 changes in sbcl-0.9.7 relative to sbcl-0.9.6:
   * minor incompatible change: (SETF CLASS-NAME) and (SETF

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 5546272..f171394 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -976,6 +976,20 @@
       (return-from fd-stream-resync
         (funcall (symbol-function (eighth entry)) stream)))))
 
+(defun get-fd-stream-character-sizer (stream)
+  (dolist (entry *external-formats*)
+    (when (member (fd-stream-external-format stream) (first entry))
+      (return-from get-fd-stream-character-sizer (ninth entry)))))
+
+(defun fd-stream-character-size (stream char)
+  (let ((sizer (get-fd-stream-character-sizer stream)))
+    (when sizer (funcall sizer char))))
+
+(defun fd-stream-string-size (stream string)
+  (let ((sizer (get-fd-stream-character-sizer stream)))
+    (when sizer
+      (loop for char across string summing (funcall sizer char)))))
+
 ;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp
 (defmacro define-external-format (external-format size output-restart
                                   out-expr in-expr)
@@ -983,8 +997,12 @@
          (out-function (symbolicate "OUTPUT-BYTES/" name))
          (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
          (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
-         (in-char-function (symbolicate "INPUT-CHAR/" name)))
+         (in-char-function (symbolicate "INPUT-CHAR/" name))
+         (size-function (symbolicate "BYTES-FOR-CHAR/" name)))
     `(progn
+      (defun ,size-function (byte)
+        (declare (ignore byte))
+        ,size)
       (defun ,out-function (stream string flush-p start end)
         (let ((start (or start 0))
               (end (or end (length string))))
@@ -1088,7 +1106,9 @@
        (cons '(,external-format ,in-function ,in-char-function ,out-function
                ,@(mapcar #'(lambda (buffering)
                              (intern (format nil format (string buffering))))
-                         '(:none :line :full)))
+                         '(:none :line :full))
+               nil ; no resync-function
+               ,size-function)
         *external-formats*)))))
 
 (defmacro define-external-format/variable-width
@@ -1099,8 +1119,11 @@
          (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
          (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
          (in-char-function (symbolicate "INPUT-CHAR/" name))
-         (resync-function (symbolicate "RESYNC/" name)))
+         (resync-function (symbolicate "RESYNC/" name))
+         (size-function (symbolicate "BYTES-FOR-CHAR/" name)))
     `(progn
+      (defun ,size-function (byte)
+        ,out-size-expr)
       (defun ,out-function (stream string flush-p start end)
         (let ((start (or start 0))
               (end (or end (length string))))
@@ -1245,7 +1268,8 @@
                ,@(mapcar #'(lambda (buffering)
                              (intern (format nil format (string buffering))))
                          '(:none :line :full))
-               ,resync-function)
+               ,resync-function
+               ,size-function)
         *external-formats*)))))
 
 ;;; Multiple names for the :ISO{,-}8859-* families are needed because on
@@ -1691,12 +1715,10 @@
        (if (zerop mode)
            nil
            (truncate size (fd-stream-element-size fd-stream)))))
-    ;; FIXME: I doubt this is correct in the presence of Unicode,
-    ;; since fd-stream FILE-POSITION is measured in bytes.
     (:file-string-length
      (etypecase arg1
-       (character 1)
-       (string (length arg1))))
+       (character (fd-stream-character-size fd-stream arg1))
+       (string (fd-stream-string-size fd-stream arg1))))
     (:file-position
      (fd-stream-file-position fd-stream arg1))))
 

diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp
index 5a2b4cd..aabdf03 100644 (file)
--- a/tests/external-format.impure.lisp
+++ b/tests/external-format.impure.lisp
@@ -203,6 +203,39 @@
                  :external-format :koi8-r)
   (let ((char (read-char s)))
     (assert (= (char-code (eval char)) #xB0))))
+(delete-file "external-format-test.txt")
+\f
+;;; tests of FILE-STRING-LENGTH
+(let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
+  (do-external-formats (xf)
+    (with-open-file (s "external-format-test.txt" :direction :output
+                       :external-format xf)
+      (loop for x across standard-characters
+            for position = (file-position s)
+            for char-length = (file-string-length s x)
+            do (write-char x s)
+            do (assert (= (file-position s) (+ position char-length))))
+      (let ((position (file-position s))
+            (string-length (file-string-length s standard-characters)))
+        (write-string standard-characters s)
+        (assert (= (file-position s) (+ position string-length)))))
+    (delete-file "external-format-test.txt")))
 
+(let ((char-codes '(0 1 255 256 511 512 1023 1024 2047 2048 4095 4096
+                    8191 8192 16383 16384 32767 32768 65535 65536 131071
+                    131072 262143 262144)))
+  (with-open-file (s "external-format-test.txt" :direction :output
+                     :external-format :utf-8)
+    (dolist (code char-codes)
+      (let* ((char (code-char code))
+             (position (file-position s))
+             (char-length (file-string-length s char)))
+        (write-char char s)
+        (assert (= (file-position s) (+ position char-length)))))
+    (let* ((string (map 'string #'code-char char-codes))
+           (position (file-position s))
+           (string-length (file-string-length s string)))
+      (write-string string s)
+      (assert (= (file-position s) (+ position string-length))))))
 \f
-(delete-file "external-format-test.txt")
+;;;; success
\ No newline at end of file

diff --git a/version.lisp-expr b/version.lisp-expr
index 25373fe..b119414 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.9.7.1"
+"0.9.7.2"