X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=e569f477e63648dfdb07d4d175df22ec58df2637;hb=1513b29bfbe948e7b431b5f67f1ff10769c192cf;hp=b23410cf82f6067460b1d34c351a92c2d4021faa;hpb=a8fa26a6e9804d3548f5bca9361a91345a689099;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index b23410c..e569f47 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -264,7 +264,7 @@
   (declare (type hairy-type type))
   (let ((spec (hairy-type-specifier type)))
     (cond ((unknown-type-p type)
-	   (when (policy nil (> speed inhibit-warnings))
+	   (when (policy *lexenv* (> speed inhibit-warnings))
 	     (compiler-note "can't open-code test of unknown type ~S"
 			    (type-specifier type)))
 	   `(%typep ,object ',spec))
@@ -361,7 +361,7 @@
 	      (res `(= (array-dimension ,obj ,i) ,dim)))))
 	(res)))))
 
-;;; If we can find a type predicate that tests for the type w/o
+;;; If we can find a type predicate that tests for the type without
 ;;; dimensions, then use that predicate and test for dimensions.
 ;;; Otherwise, just do %TYPEP.
 (defun source-transform-array-typep (obj type)
@@ -397,7 +397,7 @@
 ;;; generated in byte compiled code. (As of sbcl-0.6.5, they could
 ;;; sometimes be generated when byte compiling inline functions, but
 ;;; it's quite uncommon.) -- WHN 20000523
-(deftransform %instance-typep ((object spec) * * :when :both)
+(deftransform %instance-typep ((object spec) (* *) * :node node :when :both)
   (aver (constant-continuation-p spec))
   (let* ((spec (continuation-value spec))
 	 (class (specifier-type spec))
@@ -419,6 +419,9 @@
 			class:~%  ~S"
 		       class))
       (t
+        ;; Delay the type transform to give type propagation a chance.
+        (delay-ir1-transform node :constraint)
+
        ;; Otherwise transform the type test.
        (multiple-value-bind (pred get-layout)
 	   (cond
@@ -435,7 +438,7 @@
 	    (let ((n-layout (gensym)))
 	      `(and (,pred object)
 		    (let ((,n-layout (,get-layout object)))
-		      ,@(when (policy nil (>= safety speed))
+		      ,@(when (policy *lexenv* (>= safety speed))
 			      `((when (layout-invalid ,n-layout)
 				  (%layout-invalid-error object ',layout))))
 		      (eq ,n-layout ',layout)))))
@@ -445,7 +448,7 @@
 		  (n-layout (gensym)))
 	      `(and (,pred object)
 		    (let ((,n-layout (,get-layout object)))
-		      ,@(when (policy nil (>= safety speed))
+		      ,@(when (policy *lexenv* (>= safety speed))
 			      `((when (layout-invalid ,n-layout)
 				  (%layout-invalid-error object ',layout))))
 		      (if (eq ,n-layout ',layout)
@@ -456,6 +459,24 @@
 				 (eq (svref (layout-inherits ,n-layout)
 					    ,depthoid)
 				     ',layout))))))))
+           ((and layout (>= (layout-depthoid layout) 0))
+	    ;; hierarchical layout depths for other things (e.g.
+	    ;; CONDITIONs)
+	    (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))))
+		      (if (eq ,n-layout ',layout)
+			  t
+			  (let ((,n-inherits (layout-inherits ,n-layout)))
+			    (declare (optimize (safety 0)))
+			    (and (> (length ,n-inherits) ,depthoid)
+				 (eq (svref ,n-inherits ,depthoid)
+				     ',layout))))))))
 	   (t
 	    (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
 	    `(and (,pred object)
@@ -521,54 +542,23 @@
 
 ;;;; coercion
 
-;;; old working version
 (deftransform coerce ((x type) (* *) * :when :both)
   (unless (constant-continuation-p type)
     (give-up-ir1-transform))
   (let ((tspec (specifier-type (continuation-value type))))
     (if (csubtypep (continuation-type x) tspec)
 	'x
+	;; Note: The THE here makes sure that specifiers like
+	;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR.
 	`(the ,(continuation-value type)
-	      ,(cond ((csubtypep tspec (specifier-type 'double-float))
-		      '(%double-float x))	
-		     ;; FIXME: If LONG-FLOAT is to be supported, we
-		     ;; need to pick it off here before falling through
-		     ;; to %SINGLE-FLOAT.
-		     ((csubtypep tspec (specifier-type 'float))
-		      '(%single-float x))
-		     (t
-		      (give-up-ir1-transform)))))))
+	   ,(cond
+	     ((csubtypep tspec (specifier-type 'double-float))
+	      '(%double-float x))	
+	     ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
+	     ((csubtypep tspec (specifier-type 'float))
+	      '(%single-float x))
+	     ((csubtypep tspec (specifier-type 'simple-vector))
+	      '(coerce-to-simple-vector x))
+	     (t
+	      (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)
-    (give-up-ir1-transform))
-  (let ((tspec (specifier-type (continuation-value type))))
-    (if (csubtypep (continuation-type x) tspec)
-	'x
-	`(if #+nil (typep x type) #-nil nil
-	     x
-	     (the ,(continuation-value type)
-		  ,(cond ((csubtypep tspec (specifier-type 'double-float))
-			  '(%double-float x))	
-			 ;; FIXME: If LONG-FLOAT is to be supported,
-			 ;; we need to pick it off here before falling
-			 ;; through to %SINGLE-FLOAT.
-			 ((csubtypep tspec (specifier-type 'float))
-			  '(%single-float x))
-			 #+nil
-			 ((csubtypep tspec (specifier-type 'list))
-			  '(coerce-to-list x))
-			 #+nil
-			 ((csubtypep tspec (specifier-type 'string))
-			  '(coerce-to-simple-string x))
-			 #+nil
-			 ((csubtypep tspec (specifier-type 'bit-vector))
-			  '(coerce-to-bit-vector x))
-			 #+nil
-			 ((csubtypep tspec (specifier-type 'vector))
-			  '(coerce-to-vector x type))
-			 (t
-			  (give-up-ir1-transform))))))))