[armedbear-cvs] r13376 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl

[mevenson at common-lisp.net]

Author: mevenson
Date: Mon Jul  4 07:04:02 2011
New Revision: 13376

Log:
Implement MOP:VALIDATE-SUPERCLASS.

Start breaking out MOP defintions into separate 'mop.lisp' file.

Added:
   trunk/abcl/src/org/armedbear/lisp/mop.lisp
Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp
   trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
   trunk/abcl/test/lisp/abcl/mop-tests.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Mon Jul  4 07:03:52 2011	(r13375)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Mon Jul  4 07:04:02 2011	(r13376)
@@ -3172,4 +3172,8 @@
 (defmethod class-prototype ((class structure-class))
   (allocate-instance class))
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require "MOP"))
+
 (provide 'clos)
+

Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp	Mon Jul  4 07:03:52 2011	(r13375)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp	Mon Jul  4 07:04:02 2011	(r13376)
@@ -107,6 +107,7 @@
       (load (do-compile "require.lisp"))
       (load (do-compile "substitute.lisp"))
       (load (do-compile "clos.lisp"))
+      (load (do-compile "mop.lisp"))
       ;; Order matters for these files.
       (mapc #'do-compile '("collect.lisp"
                            "macros.lisp"

Added: trunk/abcl/src/org/armedbear/lisp/mop.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/abcl/src/org/armedbear/lisp/mop.lisp	Mon Jul  4 07:04:02 2011	(r13376)
@@ -0,0 +1,42 @@
+;;;; Does not currently include all the MOP, but it should.
+
+(in-package #:mop)
+
+(defclass funcallable-standard-class (class))
+
+(defmethod class-name ((class funcallable-standard-class))
+  'funcallable-standard-class)
+
+;;; StandardGenericFunction.java defines FUNCALLABLE-INSTANCE-FUNCTION and
+;;; SET-FUNCALLABLE-INSTANCE-FUNCTION.
+;;;
+;;; TODO 
+;;;
+;;;   1. Verify that we can make FUNCALLABLE-STANDARD-CLASS instances
+;;;      which work.
+;;;
+;;;   2. Tighten the type checks so that only instances of
+;;;      FUNCALLABLE-STANDARD-CLASS are callable.
+
+(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."))
+
+(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)))))
+
+(export '(funcallable-standard-class
+          validate-superclass))
+
+(provide 'mop)
+
+
+
+
+

Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/mop-tests.lisp	Mon Jul  4 07:03:52 2011	(r13375)
+++ trunk/abcl/test/lisp/abcl/mop-tests.lisp	Mon Jul  4 07:04:02 2011	(r13376)
@@ -360,3 +360,14 @@
   1)
 
 
+(defclass foo-class (standard-class))
+(defmethod mop:validate-superclass ((class foo-class) (superclass standard-object))
+  t)
+
+(deftest validate-superclass.1 
+    (mop:validate-superclass 
+     (make-instance 'foo-class) 
+     (make-instance 'standard-object))
+  t)
+
+