0.pre7.11:

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

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 8e860f4..e569f47 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -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)
@@ -459,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)
@@ -524,54 +542,23 @@
 \f
 ;;;; 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))))))))