X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=b6ea1d84554bf54569eaa7ec11e0795c3d6ecc9f;hb=8624c52d7620e8a4d3de23c363e843a10815f4f4;hp=cb45cf7a02d05cc67f9f8ea62428d0f4c1812714;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index cb45cf7..b6ea1d8 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -13,9 +13,6 @@
 ;;;; files for more information.
 
 (in-package "SB!C")
-
-(file-comment
-  "$Header$")
 
 ;;;; type predicate translation
 ;;;;
@@ -151,9 +148,10 @@
 
 ;;;; 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))
@@ -262,7 +260,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))
@@ -275,7 +273,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
@@ -301,6 +299,31 @@
 				`(typep ,n-obj ',(type-specifier x)))
 			    types)))))))
 
+;;; Do source transformation for TYPEP of a known intersection type.
+(defun source-transform-intersection-typep (object type)
+  ;; FIXME: This is just a placeholder; we should define a better
+  ;; version by analogy with SOURCE-TRANSFORM-UNION-TYPEP.
+  nil)
+
+;;; 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)
@@ -443,19 +466,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
@@ -483,6 +493,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
@@ -498,6 +510,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)))
@@ -523,6 +537,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)