diff --git a/NEWS b/NEWS index 27c4edf6b..16ff77f25 100644 --- 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 55462724b..f17139417 100644 --- 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 5a2b4cd04..aabdf03a6 100644 --- 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") + +;;; 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)))))) -(delete-file "external-format-test.txt") +;;;; success \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index 25373fe93..b119414ba 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.9.7.1" +"0.9.7.2"