0.9.9.9:

	Fix bug #399 (gwking on #lisp / paste 16110; reduced case by
	NJF)
	... we need to be able to derive DATA-VECTOR-REF's return type
		when we have a SIMPLE-STRING, even if the array's type
		isn't represented directly as an ARRAY-TYPE

diff --git a/BUGS b/BUGS
index 7816958..ed32c27 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -2152,18 +2152,4 @@ WORKAROUND:
   (c-string :deport-gen) ...)  in host-c-call.lisp.
 
 399: LOOP FOR ACROSS and full call to DATA-VECTOR-REF
-  The following is a simplified version of code that Gary King posted
-  to #lisp which triggers a BUG on a full call to DATA-VECTOR-REF:
-
-  (defun foo (x)
-    (declare (type (or (simple-array character (6))
-                       (simple-array character (5))) x))
-    (aref x 0))
-
-  The similar code:
-
-  (defun foo (x)
-    (declare (type (simple-array character (5)) x))
-    (aref x 0))
-
-  does not trigger the full call.
+  (fixed in sbcl-0.9.9.x)

diff --git a/NEWS b/NEWS
index c046afc..27782b1 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,8 @@
 ;;;; -*- coding: utf-8; -*-
+changes in sbcl-0.9.10 relative to sbcl-0.9.9:
+  * fixed bug #399: full call to DATA-VECTOR-REF in accesses to
+    certain complicated string types.  (reported by Gary King)
+
 changes in sbcl-0.9.9 relative to sbcl-0.9.8:
   * new platform: experimental support for the Windows operating
     system has been added.  (thanks to Alastair Bridgewater)

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 0af3b83..fd4e9a9 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -28,18 +28,33 @@
 ;;; type is going to be the array upgraded element type.
 (defun extract-upgraded-element-type (array)
   (let ((type (lvar-type array)))
-    ;; Note that this IF mightn't be satisfied even if the runtime
-    ;; value is known to be a subtype of some specialized ARRAY, because
-    ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
-    ;; which are represented in the compiler as INTERSECTION-TYPE, not
-    ;; array type.
-    (if (array-type-p type)
-        (array-type-specialized-element-type type)
-        ;; KLUDGE: there is no good answer here, but at least
-        ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
-        ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
-        ;; 2002-08-21
-        *wild-type*)))
+    (cond
+      ;; Note that this IF mightn't be satisfied even if the runtime
+      ;; value is known to be a subtype of some specialized ARRAY, because
+      ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
+      ;; which are represented in the compiler as INTERSECTION-TYPE, not
+      ;; array type.
+      ((array-type-p type) (array-type-specialized-element-type type))
+      ;; fix for bug #396.  This type logic corresponds to the special
+      ;; case for strings in HAIRY-DATA-VECTOR-REF
+      ;; (generic/vm-tran.lisp)
+      ((csubtypep type (specifier-type 'simple-string))
+       (cond
+         ((csubtypep type (specifier-type '(simple-array character (*))))
+          (specifier-type 'character))
+         #!+sb-unicode
+         ((csubtypep type (specifier-type '(simple-array base-char (*))))
+          (specifier-type 'base-char))
+         ((csubtypep type (specifier-type '(simple-array nil (*))))
+          *empty-type*)
+         ;; see KLUDGE below.
+         (t *wild-type*)))
+      (t
+       ;; KLUDGE: there is no good answer here, but at least
+       ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
+       ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
+       ;; 2002-08-21
+       *wild-type*))))
 
 (defun extract-declared-element-type (array)
   (let ((type (lvar-type array)))

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 26a5b3a..1246cdb 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1157,7 +1157,7 @@
                            c
                            0)))))
 
-;; Put this in a separate function.
+;;; Put this in a separate function.
 (defun test-constraint-propagation/cast (x)
   (when (the double-float (multiple-value-prog1
                               x
@@ -1168,4 +1168,37 @@
   (assert (assertoid:raises-error?
            (test-constraint-propagation/cast 1) type-error)))
 
+;;; bug #399
+(let ((result (make-array 50000 :fill-pointer 0 :adjustable t)))
+  (defun string->html (string &optional (max-length nil))
+    (when (and (numberp max-length)
+               (> max-length (array-dimension result 0)))
+      (setf result (make-array max-length :fill-pointer 0 :adjustable t)))
+    (let ((index 0)
+          (left-quote? t))
+      (labels ((add-char (it)
+                 (setf (aref result index) it)
+                 (incf index))
+               (add-string (it)
+                 (loop for ch across it do
+                       (add-char ch))))
+        (loop for char across string do
+              (cond ((char= char #\<)
+                     (add-string "&lt;"))
+                    ((char= char #\>)
+                     (add-string "&gt;"))
+                    ((char= char #\&)
+                     (add-string "&amp;"))
+                    ((char= char #\')
+                     (add-string "&#39;"))
+                    ((char= char #\newline)
+                     (add-string "<br>"))
+                    ((char= char #\")
+                     (if left-quote? (add-string "&#147;") (add-string "&#148;"))
+                     (setf left-quote? (not left-quote?)))
+                    (t
+                     (add-char char))))
+        (setf (fill-pointer result) index)
+        (coerce result 'string)))))
+
 ;;; success

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 9376ba1..ef90f49 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1915,3 +1915,9 @@
                  (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
                    (1+ x)))))
 
+;;; bug #399
+(with-test (:name :string-union-types)
+  (compile nil '(lambda (x)
+                 (declare (type (or (simple-array character (6))
+                                    (simple-array character (5))) x))
+                 (aref x 0))))

diff --git a/version.lisp-expr b/version.lisp-expr
index bdf26c7..e93c3b4 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.9.6"
+"0.9.9.7"