X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=8d8b421b485632ff6acc4abeedfb61c25618038d;hb=bd455348d39bee562296741689882dcb97c46ba3;hp=71061b0fbce1969242932e7a5b6958168d9ceb67;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 71061b0..8d8b421 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -24,8 +24,8 @@
 ;;;; predicates so complex that the only reasonable implentation is
 ;;;; via function call.
 ;;;;
-;;;; Some standard types (such as SEQUENCE) are best tested by letting
-;;;; the TYPEP source transform do its thing with the expansion. These
+;;;; Some standard types (such as ATOM) are best tested by letting the
+;;;; TYPEP source transform do its thing with the expansion. These
 ;;;; types (and corresponding predicates) are not maintained in this
 ;;;; association. In this case, there need not be any predicate
 ;;;; function unless it is required by the Common Lisp specification.
@@ -57,10 +57,14 @@
 ;;; constant. At worst, it will convert to %TYPEP, which will prevent
 ;;; spurious attempts at transformation (and possible repeated
 ;;; warnings.)
-(deftransform typep ((object type))
+(deftransform typep ((object type) * * :node node)
   (unless (constant-lvar-p type)
     (give-up-ir1-transform "can't open-code test of non-constant type"))
-  `(typep object ',(lvar-value type)))
+  (multiple-value-bind (expansion fail-p)
+      (source-transform-typep 'object (lvar-value type))
+    (if fail-p
+        (abort-ir1-transform)
+        expansion)))
 
 ;;; If the lvar OBJECT definitely is or isn't of the specified
 ;;; type, then return T or NIL as appropriate. Otherwise quietly
@@ -132,6 +136,7 @@
   (define-type-predicate numberp number)
   (define-type-predicate rationalp rational)
   (define-type-predicate realp real)
+  (define-type-predicate sequencep sequence)
   (define-type-predicate simple-bit-vector-p simple-bit-vector)
   (define-type-predicate simple-string-p simple-string)
   (define-type-predicate simple-vector-p simple-vector)
@@ -433,15 +438,19 @@
                               `((when (layout-invalid ,n-layout)
                                   (%layout-invalid-error object ',layout))))
                       (eq ,n-layout ',layout)))))
-           ((and (typep class 'basic-structure-classoid) layout)
+           ((and (typep class 'structure-classoid) layout)
             ;; structure type tests; hierarchical layout depths
             (let ((depthoid (layout-depthoid layout))
                   (n-layout (gensym)))
               `(and (,pred object)
                     (let ((,n-layout (,get-layout object)))
-                      ,@(when (policy *lexenv* (>= safety speed))
-                              `((when (layout-invalid ,n-layout)
-                                  (%layout-invalid-error object ',layout))))
+                      ;; we used to check for invalid layouts here,
+                      ;; but in fact that's both unnecessary and
+                      ;; wrong; it's unnecessary because structure
+                      ;; classes can't be redefined, and it's wrong
+                      ;; because it is quite legitimate to pass an
+                      ;; object with an invalid layout to a structure
+                      ;; type test.
                       (if (eq ,n-layout ',layout)
                           t
                           (and (> (layout-depthoid ,n-layout)
@@ -452,15 +461,15 @@
                                      ',layout))))))))
            ((and layout (>= (layout-depthoid layout) 0))
             ;; hierarchical layout depths for other things (e.g.
-            ;; CONDITIONs)
+            ;; CONDITION, STREAM)
             (let ((depthoid (layout-depthoid layout))
                   (n-layout (gensym))
                   (n-inherits (gensym)))
               `(and (,pred object)
                     (let ((,n-layout (,get-layout object)))
-                      ,@(when (policy *lexenv* (>= safety speed))
-                          `((when (layout-invalid ,n-layout)
-                              (%layout-invalid-error object ',layout))))
+                      (when (layout-invalid ,n-layout)
+                        (setq ,n-layout (update-object-layout-or-invalid
+                                         object ',layout)))
                       (if (eq ,n-layout ',layout)
                           t
                           (let ((,n-inherits (layout-inherits ,n-layout)))
@@ -488,6 +497,43 @@
 ;;; to that predicate. Otherwise, we dispatch off of the type's type.
 ;;; These transformations can increase space, but it is hard to tell
 ;;; when, so we ignore policy and always do them.
+(defun source-transform-typep (object type)
+  (let ((ctype (careful-specifier-type type)))
+    (or (when (not ctype)
+          (compiler-warn "illegal type specifier for TYPEP: ~S" type)
+          (return-from source-transform-typep (values nil t)))
+        (let ((pred (cdr (assoc ctype *backend-type-predicates*
+                                :test #'type=))))
+          (when pred `(,pred ,object)))
+        (typecase ctype
+          (hairy-type
+           (source-transform-hairy-typep object ctype))
+          (negation-type
+           (source-transform-negation-typep object ctype))
+          (union-type
+           (source-transform-union-typep object ctype))
+          (intersection-type
+           (source-transform-intersection-typep object ctype))
+          (member-type
+           `(if (member ,object ',(member-type-members ctype)) t))
+          (args-type
+           (compiler-warn "illegal type specifier for TYPEP: ~S" type)
+           (return-from source-transform-typep (values nil t)))
+          (t nil))
+        (typecase ctype
+          (numeric-type
+           (source-transform-numeric-typep object ctype))
+          (classoid
+           `(%instance-typep ,object ',type))
+          (array-type
+           (source-transform-array-typep object ctype))
+          (cons-type
+           (source-transform-cons-typep object ctype))
+          (character-set-type
+           (source-transform-character-set-typep object ctype))
+          (t nil))
+        `(%typep ,object ',type))))
+
 (define-source-transform typep (object spec)
   ;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
   ;; since that would overlook other kinds of constants. But it turns
@@ -496,43 +542,7 @@
   ;; source transform another chance, so it all works out OK, in a
   ;; weird roundabout way. -- WHN 2001-03-18
   (if (and (consp spec) (eq (car spec) 'quote))
-      (let ((type (careful-specifier-type (cadr spec))))
-        (or (when (not type)
-              (compiler-warn "illegal type specifier for TYPEP: ~S"
-                             (cadr spec))
-              `(%typep ,object ,spec))
-            (let ((pred (cdr (assoc type *backend-type-predicates*
-                                    :test #'type=))))
-              (when pred `(,pred ,object)))
-            (typecase type
-              (hairy-type
-               (source-transform-hairy-typep object type))
-              (negation-type
-               (source-transform-negation-typep object type))
-              (union-type
-               (source-transform-union-typep object type))
-              (intersection-type
-               (source-transform-intersection-typep object type))
-              (member-type
-               `(if (member ,object ',(member-type-members type)) t))
-              (args-type
-               (compiler-warn "illegal type specifier for TYPEP: ~S"
-                              (cadr spec))
-               `(%typep ,object ,spec))
-              (t nil))
-            (typecase type
-              (numeric-type
-               (source-transform-numeric-typep object type))
-              (classoid
-               `(%instance-typep ,object ,spec))
-              (array-type
-               (source-transform-array-typep object type))
-              (cons-type
-               (source-transform-cons-typep object type))
-              (character-set-type
-               (source-transform-character-set-typep object type))
-              (t nil))
-            `(%typep ,object ,spec)))
+      (source-transform-typep object (cadr spec))
       (values nil t)))
 
 ;;;; coercion