From 7374cac4bf6ad3b9f109e4a4d0558325b2cad230 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 7 Oct 2012 14:12:59 +0300
Subject: [PATCH] teach NODE-CONSERVATIVE-TYPE about union types

  Conservative type of STRING is STRING -- and this makes it so.

  Fixes lp#1050768 (but also future-proof ARRAY-IN-BOUNDS-P against
  '*) explicitly.
---
 NEWS                         |    2 ++
 src/compiler/array-tran.lisp |    5 +++++
 src/compiler/ir1opt.lisp     |    7 +++++++
 tests/compiler.pure.lisp     |   16 ++++++++++++++++
 4 files changed, 30 insertions(+)

diff --git a/NEWS b/NEWS
index 29bfc32..9057028 100644
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,8 @@ changes relative to sbcl-1.1.0:
     (thanks to SANO Masatoshi)
   * bug fix: PARSE-NATIVE-NAMESTRING performed non-native parsing when
     :JUNK-ALLOWED was true.
+  * bug fix: type derivation inferred overly conservative types for
+    unions of array types. (lp#1050768)
 
 changes in sbcl-1.1.0 relative to sbcl-1.0.58:
   * enhancement: New variable, sb-ext:*disassemble-annotate* for controlling
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 0cf9279..baf1b98 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -169,6 +169,11 @@
     (block nil
       (let ((dimensions (array-type-dimensions-or-give-up
                          (lvar-conservative-type array))))
+        ;; Might be *. (Note: currently this is never true, because the type
+        ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but
+        ;; let's keep this future proof.)
+        (when (eq '* dimensions)
+          (give-up-ir1-transform "array bounds unknown"))
         ;; shortcut for zero dimensions
         (when (some (lambda (dim)
                       (and (bound-known-p dim) (zerop dim)))
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 7d4fdd2..dc6769b 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -166,7 +166,14 @@
               :specialized-element-type (array-type-specialized-element-type type))
              ;; Simple arrays cannot change at all.
              type))
+        ((union-type-p type)
+         ;; Conservative union type is an union of conservative types.
+         (let ((res *empty-type*))
+           (dolist (part (union-type-types type) res)
+             (setf res (type-union res (conservative-type part))))))
         (t
+         ;; Catch-all.
+         ;;
          ;; If the type contains some CONS types, the conservative type contains all
          ;; of them.
          (when (types-equal-or-intersect type (specifier-type 'cons))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 85d4d1c..7d8faf1 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4341,3 +4341,19 @@
                                 (cons (or (car x) (meh)))
                                 (t (meh)))))))
                    (funcall (eh x)))) t t)))
+
+(with-test (:name (:bug-1050768 :symptom))
+  ;; Used to signal an error.
+  (compile nil
+           `(lambda (string position)
+              (char string position)
+              (array-in-bounds-p string (1+ position)))))
+
+(with-test (:name (:bug-1050768 :cause))
+  (let ((types `((string string)
+                 ((or (simple-array character 24) (vector t 24))
+                  (or (simple-array character 24) (vector t))))))
+    (dolist (pair types)
+      (destructuring-bind (orig conservative) pair
+        (assert sb-c::(type= (specifier-type cl-user::conservative)
+                             (conservative-type (specifier-type cl-user::orig))))))))
-- 
1.7.10.4