0.6.11.17:

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

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index e1071a8..1c72075 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
@@ -34,12 +37,10 @@
 ;;;; part of the backend; different backends can support different
 ;;;; sets of predicates.
 
+;;; Establish an association between the type predicate NAME and the
+;;; corresponding TYPE. This causes the type predicate to be
+;;; recognized for purposes of optimization.
 (defmacro define-type-predicate (name type)
-  #!+sb-doc
-  "Define-Type-Predicate Name Type
-  Establish an association between the type predicate Name and the
-  corresponding Type. This causes the type predicate to be recognized for
-  purposes of optimization."
   `(%define-type-predicate ',name ',type))
 (defun %define-type-predicate (name specifier)
   (let ((type (specifier-type specifier)))
@@ -71,9 +72,9 @@
   (declare (type continuation object) (type ctype type))
   (let ((otype (continuation-type object)))
     (cond ((not (types-intersect otype type))
-          'nil)
+          nil)
          ((csubtypep otype type)
-          't)
+          t)
          (t
           (give-up-ir1-transform)))))
 
@@ -105,11 +106,15 @@
     `(or (class-cell-class ',cell)
         (error "class not yet defined: ~S" name))))
 \f
-;;;; standard type predicates
+;;;; standard type predicates, i.e. those defined in package COMMON-LISP,
+;;;; plus at least one oddball (%INSTANCEP)
+;;;;
+;;;; Various other type predicates (e.g. low-level representation
+;;;; stuff like SIMPLE-ARRAY-SINGLE-FLOAT-P) are defined elsewhere.
 
-;;; FIXME: needed only at cold load time, can be uninterned afterwards;
-;;; or perhaps could just be done at toplevel
-(defun define-standard-type-predicates ()
+;;; FIXME: This function is only called once, at top level. Why not
+;;; just expand all its operations into toplevel code?
+(defun !define-standard-type-predicates ()
   (define-type-predicate arrayp array)
   ; (The ATOM predicate is handled separately as (NOT CONS).)
   (define-type-predicate bit-vector-p bit-vector)
@@ -136,8 +141,7 @@
   (define-type-predicate funcallable-instance-p funcallable-instance)
   (define-type-predicate symbolp symbol)
   (define-type-predicate vectorp vector))
-
-(define-standard-type-predicates)
+(!define-standard-type-predicates)
 \f
 ;;;; transforms for type predicates not implemented primitively
 ;;;;
@@ -283,21 +287,26 @@
   (let* ((types (union-type-types type))
         (ltype (specifier-type 'list))
         (mtype (find-if #'member-type-p types)))
-    (cond ((and mtype (csubtypep ltype type))
-          (let ((members (member-type-members mtype)))
-            (once-only ((n-obj object))
-              `(if (listp ,n-obj)
-                   t
-                   (typep ,n-obj
-                          '(or ,@(mapcar #'type-specifier
-                                         (remove (specifier-type 'cons)
-                                                 (remove mtype types)))
-                               (member ,@(remove nil members))))))))
-         (t
-          (once-only ((n-obj object))
-            `(or ,@(mapcar #'(lambda (x)
-                               `(typep ,n-obj ',(type-specifier x)))
-                           types)))))))
+    (if (and mtype (csubtypep ltype type))
+       (let ((members (member-type-members mtype)))
+         (once-only ((n-obj object))
+           `(or (listp ,n-obj)
+                (typep ,n-obj
+                       '(or ,@(mapcar #'type-specifier
+                                      (remove (specifier-type 'cons)
+                                              (remove mtype types)))
+                            (member ,@(remove nil members)))))))
+       (once-only ((n-obj object))
+         `(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)
@@ -477,6 +486,12 @@
 ;;; simplification. Instance type tests are converted to
 ;;; %INSTANCE-TYPEP to allow type propagation.
 (def-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
+  ;; out that the DEFTRANSFORM for TYPEP detects any constant
+  ;; continuation, 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) (eq (car spec) 'quote))
       (let ((type (specifier-type (cadr spec))))
        (or (let ((pred (cdr (assoc type *backend-type-predicates*
@@ -487,6 +502,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