X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=c1f818d5b344c12596201b7f2e7e53c9c0764048;hb=5745b5a5b2e3b967bf3876b4306f31b3c78495fa;hp=4f47e172178744b148aa04c313c2c8fc1ee5338d;hpb=5a9a81ca693a7b82d810cbe725818cd96244099e;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 4f47e17..c1f818d 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -57,9 +57,11 @@
 ;;; constant. At worst, it will convert to %TYPEP, which will prevent
 ;;; spurious attempts at transformation (and possible repeated
 ;;; warnings.)
-(deftransform typep ((object type) * * :node node)
+(deftransform typep ((object type &optional env) * * :node node)
   (unless (constant-lvar-p type)
     (give-up-ir1-transform "can't open-code test of non-constant type"))
+  (unless (and (constant-lvar-p env) (null (lvar-value env)))
+    (give-up-ir1-transform "environment argument present and not null"))
   (multiple-value-bind (expansion fail-p)
       (source-transform-typep 'object (lvar-value type))
     (if fail-p
@@ -406,14 +408,24 @@
              ;; not safe to assume here that it will eventually
              ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
              (not (unknown-type-p (array-type-element-type type)))
-             (eq (array-type-complexp stype) (array-type-complexp type)))
-          (once-only ((n-obj obj))
-            (multiple-value-bind (tests headerp)
-                (test-array-dimensions n-obj type stype)
-              `(and (,pred ,n-obj)
-                    ,@tests
-                    ,@(test-array-element-type n-obj type stype headerp))))
-          `(%typep ,obj ',(type-specifier type)))))
+             (or (eq (array-type-complexp stype) (array-type-complexp type))
+                 (and (eql (array-type-complexp stype) :maybe)
+                      (eql (array-type-complexp type) t))))
+        (once-only ((n-obj obj))
+          (multiple-value-bind (tests headerp)
+              (test-array-dimensions n-obj type stype)
+            `(and (,pred ,n-obj)
+                  ,@(when (and (eql (array-type-complexp stype) :maybe)
+                               (eql (array-type-complexp type) t))
+                      ;; KLUDGE: this is a bit lame; if we get here,
+                      ;; we already know that N-OBJ is an array, but
+                      ;; (NOT SIMPLE-ARRAY) doesn't know that.  On the
+                      ;; other hand, this should get compiled down to
+                      ;; two widetag tests, so it's only a bit lame.
+                      `((typep ,n-obj '(not simple-array))))
+                  ,@tests
+                  ,@(test-array-element-type n-obj type stype headerp))))
+        `(%typep ,obj ',(type-specifier type)))))
 
 ;;; Transform a type test against some instance type. The type test is
 ;;; flushed if the result is known at compile time. If not properly
@@ -574,14 +586,15 @@
           (t nil))
         `(%typep ,object ',type))))
 
-(define-source-transform typep (object spec)
+(define-source-transform typep (object spec &optional env)
   ;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
   ;; since that would overlook other kinds of constants. But it turns
   ;; out that the DEFTRANSFORM for TYPEP detects any constant
   ;; lvar, transforms it into a quoted form, and gives this
   ;; source transform another chance, so it all works out OK, in a
   ;; weird roundabout way. -- WHN 2001-03-18
-  (if (and (consp spec)
+  (if (and (not env)
+           (consp spec)
            (eq (car spec) 'quote)
            (or (not *allow-instrumenting*)
                (policy *lexenv* (= store-coverage-data 0))))