0.6.11.11:

[sbcl.git] / src / compiler / typetran.lisp

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index b0160e4..276aa8c 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -12,6 +12,9 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
+;;; FIXME: Many of the functions in this file could probably be
+;;; byte-compiled, since they're one-pass, cons-heavy code.
+
 (in-package "SB!C")
 \f
 ;;;; type predicate translation
@@ -148,9 +151,10 @@
 \f
 ;;;; TYPEP source transform
 
-;;; Return a form that tests the variable N-Object for being in the binds
-;;; specified by Type. Base is the name of the base type, for declaration. We
-;;; make safety locally 0 to inhibit any checking of this assertion.
+;;; Return a form that tests the variable N-OBJECT for being in the
+;;; binds specified by TYPE. BASE is the name of the base type, for
+;;; declaration. We make SAFETY locally 0 to inhibit any checking of
+;;; this assertion.
 #!-negative-zero-is-not-zero
 (defun transform-numeric-bound-test (n-object type base)
   (declare (type numeric-type type))
@@ -259,7 +263,7 @@
   (declare (type hairy-type type))
   (let ((spec (hairy-type-specifier type)))
     (cond ((unknown-type-p type)
-          (when (policy nil (> speed brevity))
+          (when (policy nil (> speed inhibit-warnings))
             (compiler-note "can't open-code test of unknown type ~S"
                            (type-specifier type)))
           `(%typep ,object ',spec))
@@ -272,7 +276,7 @@
                                              `(typep ,n-obj ',x))
                                          (rest spec))))))))))
 
-;;; Do source transformation for Typep of a known union type. If a
+;;; Do source transformation for TYPEP of a known union type. If a
 ;;; union type contains LIST, then we pull that out and make it into a
 ;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
 ;;; will be a subtype even without there being any (member NIL). We
@@ -294,10 +298,36 @@
                                (member ,@(remove nil members))))))))
          (t
           (once-only ((n-obj object))
-            `(or ,@(mapcar #'(lambda (x)
-                               `(typep ,n-obj ',(type-specifier x)))
+            `(or ,@(mapcar (lambda (x)
+                             `(typep ,n-obj ',(type-specifier x)))
                            types)))))))
 
+;;; Do source transformation for TYPEP of a known intersection type.
+(defun source-transform-intersection-typep (object type)
+  (once-only ((n-obj object))
+    `(and ,@(mapcar (lambda (x)
+                     `(typep ,n-obj ',(type-specifier x)))
+                   (intersection-type-types type)))))
+
+;;; If necessary recurse to check the cons type.
+(defun source-transform-cons-typep (object type)
+  (let* ((car-type (cons-type-car-type type))
+        (cdr-type (cons-type-cdr-type type)))
+    (let ((car-test-p (not (or (type= car-type *wild-type*)
+                              (type= car-type (specifier-type t)))))
+         (cdr-test-p (not (or (type= cdr-type *wild-type*)
+                              (type= cdr-type (specifier-type t))))))
+      (if (and (not car-test-p) (not cdr-test-p))
+         `(consp ,object)
+         (once-only ((n-obj object))
+           `(and (consp ,n-obj)
+                 ,@(if car-test-p
+                       `((typep (car ,n-obj)
+                                ',(type-specifier car-type))))
+                 ,@(if cdr-test-p
+                       `((typep (cdr ,n-obj)
+                                ',(type-specifier cdr-type))))))))))
+ 
 ;;; Return the predicate and type from the most specific entry in
 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
 (defun find-supertype-predicate (type)
@@ -440,19 +470,6 @@
                                    ',(find-class-cell name)
                                    object)))))))))
 
-#|
-;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE
-;;; which corresponds to the value returned by
-;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that
-;;; result might change when we encounter a DEFTYPE.
-(declaim (maybe-inline upgraded-array-element-ctype-2))
-(defun upgraded-array-element-ctype-2 (spec)
-  (let ((ctype (specifier-type `(array ,spec))))
-    (values (array-type-specialized-element-type
-            (specifier-type `(array ,spec)))
-           (not (unknown-type-p (array-type-element-type ctype))))))
-|#
-
 ;;; If the specifier argument is a quoted constant, then we consider
 ;;; converting into a simple predicate or other stuff. If the type is
 ;;; constant, but we can't transform the call, then we convert to
@@ -480,6 +497,8 @@
               (source-transform-hairy-typep object type))
              (union-type
               (source-transform-union-typep object type))
+             (intersection-type
+              (source-transform-intersection-typep object type))
              (member-type
               `(member ,object ',(member-type-members type)))
              (args-type
@@ -495,6 +514,8 @@
                    `(%instance-typep ,object ,spec))
                   (array-type
                    (source-transform-array-typep object type))
+                  (cons-type
+                   (source-transform-cons-typep object type))
                   (t nil)))
            `(%typep ,object ,spec)))
       (values nil t)))
@@ -520,6 +541,7 @@
                      (give-up-ir1-transform)))))))
 
 ;;; KLUDGE: new broken version -- 20000504
+;;; FIXME: should be fixed or deleted
 #+nil
 (deftransform coerce ((x type) (* *) * :when :both)
   (unless (constant-continuation-p type)