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 (file)
--- 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 (file)
--- 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 (file)
--- 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)))))
 \f
 ;;;; case frobbing streams, used by FORMAT ~(...~)
 

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index f94f1d0..eca0cc2 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (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".)
-"1.0.23.63"
+"1.0.23.64"