[Openmcl-cvs-notifications] r11263 - /trunk/source/compiler/optimizers.lisp

[gz at clozure.com]

Author: gz
Date: Thu Oct 30 11:03:36 2008
New Revision: 11263

Log:
Propagate r11262 to trunk

Modified:
    trunk/source/compiler/optimizers.lisp

Modified: trunk/source/compiler/optimizers.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/optimizers.lisp (original)
+++ trunk/source/compiler/optimizers.lisp Thu Oct 30 11:03:36 2008
@@ -1868,9 +1868,15 @@
 (define-compiler-macro aref (&whole call a &rest subscripts &environment e=
nv)
   (let* ((ctype (if (nx-form-typep a 'array env)
                   (specifier-type (nx-form-type a env) env)))
-         (type (if ctype (type-specifier (array-ctype-specialized-element-=
type ctype))))
-         (useful (unless (or (eq type *) (eq type t))
-                   type)))
+         (ectype (typecase ctype
+                   (array-ctype (array-ctype-specialized-element-type ctyp=
e))
+                   (union-ctype (when (every #'array-ctype-p (union-ctype-=
types ctype))
+                                  (%type-union
+                                   (mapcar (lambda (ct) (array-ctype-speci=
alized-element-type ct))
+                                           (union-ctype-types ctype)))))))
+         (etype (and ectype (type-specifier ectype)))
+         (useful (unless (or (eq etype *) (eq etype t))
+                   etype)))
     (if (=3D 2 (length subscripts))
       (setq call `(%aref2 ,a , at subscripts))
       (if (=3D 3 (length subscripts))