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

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Sun Jun 17 10:05:19 2012
New Revision: 13976

Log:
Correct default superclass for funcallable-standard-classes

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

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Jun 17 09:34:58 2012	(r13975)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Jun 17 10:05:19 2012	(r13976)
@@ -113,6 +113,8 @@
   (find-class 'funcallable-standard-class))
 (defconstant +the-structure-class+ (find-class 'structure-class))
 (defconstant +the-standard-object-class+ (find-class 'standard-object))
+(defconstant +the-funcallable-standard-object-class+
+  (find-class 'funcallable-standard-object))
 (defconstant +the-standard-method-class+ (find-class 'standard-method))
 (defconstant +the-forward-referenced-class+
   (find-class 'forward-referenced-class))
@@ -843,8 +845,12 @@
                                              &key direct-superclasses direct-slots
                                              direct-default-initargs
                                              &allow-other-keys)
-  (let ((supers (or direct-superclasses
-                    (list +the-standard-object-class+))))
+  (let ((supers (cond (direct-superclasses)
+                      ((subtypep (class-of class)
+                                 +the-funcallable-standard-class+)
+                       (list +the-funcallable-standard-object-class+))
+                      ((subtypep (class-of class) +the-standard-class+)
+                       (list +the-standard-object-class+)))))
     (setf (class-direct-superclasses class) supers)
     ;; FIXME (rudi 2012-03-22: follow the AMOP spec here when classes
     ;; are reinitialized: call add-direct-subclass for newly-added