From: Nikodemus Siivola Date: Mon, 22 Dec 2008 13:38:04 +0000 (+0000) Subject: 1.0.23.64: fixed bug 395 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f5522c7149744e4faf34313b18d0d3588d2a9d98;p=sbcl.git 1.0.23.64: fixed bug 395 * Add support for base-strings in fill-pointer output streams. * Also fix a bug revealed by this change in derivation of ARRAY-ELEMENT-TYPE return type. --- diff --git a/BUGS b/BUGS index 1239d6c..a032032 100644 --- a/BUGS +++ b/BUGS @@ -1367,20 +1367,6 @@ WORKAROUND: (FOO 1 2) gives NO-APPLICABLE-METHOD rather than an argument count error. -395: Unicode and streams - One of the remaining problems in SBCL's Unicode support is the lack - of generality in certain streams. - a. FILL-POINTER-STREAMs: SBCL refuses to write (e.g. using FORMAT) - to streams made from strings that aren't character strings with - fill-pointers: - (let ((v (make-array 5 :fill-pointer 0 :element-type 'standard-char))) - (format v "foo") - v) - should return a non-simple base string containing "foo" but - instead errors. - - (reported on sbcl-help by "tichy") - 396: block-compilation bug (let ((x 1)) (dotimes (y 10) diff --git a/NEWS b/NEWS index 9f3de4a..d06d739 100644 --- a/NEWS +++ b/NEWS @@ -50,6 +50,11 @@ and DEFSTRUCT forms :INCLUDEind structure classes defined using DEFCLASS :METACLASS STRUCTURE-CLASS now inherit their initforms. (reported by Bruno Haible and Stephen Wilson) + * bug fix: #395; fill-pointer output streams used now support + element-type BASE-CHAR as well. + * bug fix: compiler error when attempting to derive return value of + ARRAY-ELEMENT-TYPE when the array type was a union of intersection + types. changes in sbcl-1.0.23 relative to 1.0.22: * enhancement: when disassembling method functions, disassembly diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 19b3f8e..245e47e 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1557,10 +1557,10 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") ;;; 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. +;;; FIXME: need to support (VECTOR NIL), ideally without destroying all hope +;;; of efficiency. (deftype string-with-fill-pointer () - '(and (vector character) + '(and (or (vector character) (vector base-char)) (satisfies array-has-fill-pointer-p))) (defstruct (fill-pointer-output-stream @@ -1579,53 +1579,63 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (current+1 (1+ current))) (declare (fixnum current)) (with-array-data ((workspace buffer) (start) (end)) - (declare (type (simple-array character (*)) workspace)) - (let ((offset-current (+ start current))) - (declare (fixnum offset-current)) - (if (= offset-current end) - (let* ((new-length (1+ (* current 2))) - (new-workspace (make-string new-length))) - (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 - current+1 0 new-length nil)) - (setf (fill-pointer buffer) current+1)) - (setf (schar workspace offset-current) character))) + (string-dispatch + ((simple-array character (*)) + (simple-array base-char (*))) + workspace + (let ((offset-current (+ start current))) + (declare (fixnum offset-current)) + (if (= offset-current end) + (let* ((new-length (1+ (* current 2))) + (new-workspace + (ecase (array-element-type workspace) + (character (make-string new-length + :element-type 'character)) + (base-char (make-string new-length + :element-type 'base-char))))) + (replace new-workspace workspace :start2 start :end2 offset-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)) + (setf (char workspace offset-current) character)))) current+1)) (defun fill-pointer-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer)) - (string-len (- end start)) - (dst-end (+ string-len current))) - (declare (fixnum current dst-end string-len)) - (with-array-data ((workspace buffer) (dst-start) (dst-length)) - (declare (type (simple-array character (*)) workspace)) - (let ((offset-dst-end (+ dst-start dst-end)) - (offset-current (+ dst-start current))) - (declare (fixnum offset-dst-end offset-current)) - (if (> offset-dst-end dst-length) - (let* ((new-length (+ (the fixnum (* current 2)) string-len)) - (new-workspace (make-string new-length))) - (declare (type (simple-array character (*)) new-workspace)) - (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)) - (replace workspace string - :start1 offset-current :start2 start :end2 end))) - dst-end)) + (declare (fixnum start end)) + (string-dispatch + ((simple-array character (*)) + (simple-array base-char (*))) + string + (let* ((buffer (fill-pointer-output-stream-string stream)) + (current (fill-pointer buffer)) + (string-len (- end start)) + (dst-end (+ string-len current))) + (declare (fixnum current dst-end string-len)) + (with-array-data ((workspace buffer) (dst-start) (dst-length)) + (let ((offset-dst-end (+ dst-start dst-end)) + (offset-current (+ dst-start current))) + (declare (fixnum offset-dst-end offset-current)) + (if (> offset-dst-end dst-length) + (let* ((new-length (+ (the fixnum (* current 2)) string-len)) + (new-workspace + (ecase (array-element-type workspace) + (character (make-string new-length + :element-type 'character)) + (base-char (make-string new-length + :element-type 'base-char))))) + (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)) + (replace workspace string + :start1 offset-current :start2 start :end2 end))) + dst-end))) (defun fill-pointer-misc (stream operation &optional arg1 arg2) (declare (ignore arg2)) @@ -1659,8 +1669,9 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (if found (- end (the fixnum found)) current))))) - (:element-type (array-element-type - (fill-pointer-output-stream-string stream))))) + (:element-type + (array-element-type + (fill-pointer-output-stream-string stream))))) ;;;; case frobbing streams, used by FORMAT ~(...~) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index f94f1d0..eca0cc2 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -4073,13 +4073,15 @@ (specifier-type (consify element-type))) (t (error "can't understand type ~S~%" element-type)))))) - (cond ((array-type-p array-type) - (get-element-type array-type)) - ((union-type-p array-type) - (apply #'type-union - (mapcar #'get-element-type (union-type-types array-type)))) - (t - *universal-type*))))) + (labels ((recurse (type) + (cond ((array-type-p type) + (get-element-type type)) + ((union-type-p type) + (apply #'type-union + (mapcar #'recurse (union-type-types type)))) + (t + *universal-type*)))) + (recurse array-type))))) ;;; Like CMU CL, we use HEAPSORT. However, other than that, this code ;;; isn't really related to the CMU CL code, since instead of trying diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 16eeee4..381bb2f 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2670,3 +2670,8 @@ (with-test (:name :late-bound-primitive) (compile nil `(lambda () (funcall 'cons 1)))) + +(with-test (:name :hairy-array-element-type-derivation) + (compile nil '(lambda (x) + (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x)) + (array-element-type x)))) diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp index 804e781..b35c61e 100644 --- a/tests/stream.pure.lisp +++ b/tests/stream.pure.lisp @@ -332,3 +332,8 @@ (read-byte stream)) (assert (not (listen stream))))) (ignore-errors (delete-file listen-testfile-name)))))) + +(with-test (:name :bug-395) + (let ((v (make-array 5 :fill-pointer 0 :element-type 'standard-char))) + (format v "foo") + (assert (equal (coerce "foo" 'base-string) v)))) diff --git a/version.lisp-expr b/version.lisp-expr index 26cd26e..6f84a11 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".) -"1.0.23.63" +"1.0.23.64"