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

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Wed May  2 04:56:59 2012
New Revision: 13923

Log:
Implement validate-superclass

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

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Mon Apr 30 00:47:19 2012	(r13922)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Wed May  2 04:56:59 2012	(r13923)
@@ -104,6 +104,8 @@
 (export '(class-precedence-list class-slots
           slot-definition-name))
 (defconstant +the-standard-class+ (find-class 'standard-class))
+(defconstant +the-funcallable-standard-class+
+  (find-class 'funcallable-standard-class))
 (defconstant +the-structure-class+ (find-class 'structure-class))
 (defconstant +the-standard-object-class+ (find-class 'standard-object))
 (defconstant +the-standard-method-class+ (find-class 'standard-method))

Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/java.lisp	Mon Apr 30 00:47:19 2012	(r13922)
+++ trunk/abcl/src/org/armedbear/lisp/java.lisp	Wed May  2 04:56:59 2012	(r13923)
@@ -439,6 +439,14 @@
 	   :initform (error "class is required")
 	   :reader java-class-jclass)))
 
+;;; FIXME (rudi 2012-05-02): consider replacing the metaclass of class
+;;; java-object to be java-class here instead of allowing this subclass
+;;; relationship.  On the other hand, abcl ran for the longest time
+;;; without an implementation of validate-superclass, so this doesn't
+;;; introduce new sources for bugs.
+(defmethod mop:validate-superclass ((class java-class) (superclass built-in-class))
+  t)
+
 ;;init java.lang.Object class
 (defconstant +java-lang-object-class+
   (%register-java-class +java-lang-object+

Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/mop.lisp	Mon Apr 30 00:47:19 2012	(r13922)
+++ trunk/abcl/src/org/armedbear/lisp/mop.lisp	Wed May  2 04:56:59 2012	(r13923)
@@ -13,20 +13,29 @@
 ;;;   2. Tighten the type checks so that only instances of
 ;;;      FUNCALLABLE-STANDARD-CLASS are callable.
 
+;;; AMOP pg. 240ff.
 (defgeneric validate-superclass (class superclass)
  (:documentation 
   "This generic function is called to determine whether the class
   superclass is suitable for use as a superclass of class."))
 
-;;; TODO Hook VALIDATE-SUPERCLASS into during class metaobject
-;;; initialization and reinitialization. (AMOP p.240-1)
 (defmethod validate-superclass ((class class) (superclass class))
-  (or (eql (class-name superclass) t)
-      (eql (class-name class) (class-name superclass))
-      (or (and (eql (class-name class) 'standard-class)
-               (eql (class-name superclass) 'funcallable-standard-class))
-          (and (eql (class-name class) 'funcallable-standard-class)
-               (eql (class-name superclass) 'standard-class)))))
+  (or (eql superclass +the-T-class+)
+      (eql (class-of class) (class-of superclass))
+      (or (and (eql (class-of class) +the-standard-class+)
+               (eql (class-of superclass) +the-funcallable-standard-class+))
+          (and (eql (class-of class) +the-funcallable-standard-class+)
+               (eql (class-of superclass) +the-standard-class+)))))
+
+(defmethod shared-initialize :before ((instance class)
+                                      slot-names
+                                      &key direct-superclasses
+                                      &allow-other-keys)
+  (declare (ignore slot-names))
+  (dolist (superclass direct-superclasses)
+    (assert (validate-superclass instance superclass) (instance superclass)
+            "Class ~S is not compatible with superclass ~S"
+            instance superclass)))
 
 (export '(;; classes
           funcallable-standard-object