[armedbear-cvs] r11586 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Jan 24 20:36:52 2009
New Revision: 11586

Log:
Eliminate the pesky beeps in TYPE-OF.1; however unfortunately, this breaks TYPE-OF.4 for the case of "". Now go and search!

Modified:
   trunk/abcl/src/org/armedbear/lisp/subtypep.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/subtypep.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/subtypep.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/subtypep.lisp	Sat Jan 24 20:36:52 2009
@@ -93,7 +93,7 @@
                  (SIMPLE-BIT-VECTOR BIT-VECTOR SIMPLE-ARRAY)
                  (SIMPLE-CONDITION CONDITION)
                  (SIMPLE-ERROR SIMPLE-CONDITION ERROR)
-                 (SIMPLE-STRING SIMPLE-BASE-STRING BASE-STRING STRING SIMPLE-ARRAY)
+                 (SIMPLE-STRING BASE-STRING STRING SIMPLE-ARRAY)
                  (SIMPLE-TYPE-ERROR SIMPLE-CONDITION TYPE-ERROR)
                  (SIMPLE-VECTOR VECTOR SIMPLE-ARRAY)
                  (SIMPLE-WARNING SIMPLE-CONDITION WARNING)
@@ -483,6 +483,10 @@
             (eq type2 t)
             (and (classp type2) (eq (%class-name type2) t)))
     (return-from %subtypep (values t t)))
+  (when (classp type1)
+    (setf type1 (%class-name type1)))
+  (when (classp type2)
+    (setf type2 (%class-name type2)))
   (let ((ct1 (ctype type1))
         (ct2 (ctype type2)))
     (multiple-value-bind (subtype-p valid-p)