[armedbear-cvs] r11378 - branches/scripting/j/src/org/armedbear/lisp

[Alessio Stalla]

Author: astalla
Date: Mon Nov  3 22:33:06 2008
New Revision: 11378

Log:
Added CLOS method dispatch on Java classes: a new java:jclass specializer is provided, plus a new JAVA-CLASS metaclass has been introduced to represent all Java classes in the context of CLOS.

Modified:
   branches/scripting/j/src/org/armedbear/lisp/Autoload.java
   branches/scripting/j/src/org/armedbear/lisp/JavaObject.java
   branches/scripting/j/src/org/armedbear/lisp/StandardClass.java
   branches/scripting/j/src/org/armedbear/lisp/Symbol.java
   branches/scripting/j/src/org/armedbear/lisp/clos.lisp

Modified: branches/scripting/j/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/Autoload.java	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/Autoload.java	Mon Nov  3 22:33:06 2008
@@ -489,6 +489,7 @@
         autoload(PACKAGE_EXT, "thread-unlock", "ThreadLock", true);
         autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy");
         autoload(PACKAGE_JAVA, "%jimplement-interface", "JProxy");
+        autoload(PACKAGE_JAVA, "%find-java-class", "JavaClass");
         autoload(PACKAGE_JAVA, "%jmake-invocation-handler", "JProxy");
         autoload(PACKAGE_JAVA, "%jmake-proxy", "JProxy");
         autoload(PACKAGE_JAVA, "%jnew-runtime-class", "RuntimeClass");

Modified: branches/scripting/j/src/org/armedbear/lisp/JavaObject.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/JavaObject.java	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/JavaObject.java	Mon Nov  3 22:33:06 2008
@@ -37,7 +37,11 @@
 
     public LispObject classOf()
     {
-        return BuiltInClass.JAVA_OBJECT;
+    	if(obj == null) {
+    		return BuiltInClass.JAVA_OBJECT;
+    	} else {
+    		return JavaClass.findJavaClass(obj.getClass());
+    	}
     }
 
     public LispObject typep(LispObject type) throws ConditionThrowable
@@ -46,6 +50,9 @@
             return T;
         if (type == BuiltInClass.JAVA_OBJECT)
             return T;
+        if(type instanceof JavaClass && obj != null) {
+        	return ((JavaClass) type).getJavaClass().isAssignableFrom(obj.getClass()) ? T : NIL;
+        }
         return super.typep(type);
     }
 

Modified: branches/scripting/j/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/StandardClass.java	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/StandardClass.java	Mon Nov  3 22:33:06 2008
@@ -107,6 +107,9 @@
   public static final StandardClass BUILT_IN_CLASS =
     addStandardClass(Symbol.BUILT_IN_CLASS, list1(CLASS));
 
+  public static final StandardClass JAVA_CLASS =
+	    addStandardClass(Symbol.JAVA_CLASS, list1(CLASS));
+  
   public static final StandardClass FORWARD_REFERENCED_CLASS =
     addStandardClass(Symbol.FORWARD_REFERENCED_CLASS, list1(CLASS));
 
@@ -264,6 +267,8 @@
                                list1(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERANDS")))));
     BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, STANDARD_OBJECT,
                           BuiltInClass.CLASS_T);
+    JAVA_CLASS.setCPL(JAVA_CLASS, CLASS, STANDARD_OBJECT,
+            BuiltInClass.CLASS_T);
     CELL_ERROR.setCPL(CELL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION,
                       STANDARD_OBJECT, BuiltInClass.CLASS_T);
     CELL_ERROR.setDirectSlotDefinitions(

Modified: branches/scripting/j/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/Symbol.java	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/Symbol.java	Mon Nov  3 22:33:06 2008
@@ -2874,6 +2874,8 @@
     PACKAGE_JAVA.addExternalSymbol("JAVA-EXCEPTION-CAUSE");
   public static final Symbol JAVA_OBJECT =
     PACKAGE_JAVA.addExternalSymbol("JAVA-OBJECT");
+  public static final Symbol JAVA_CLASS =
+	    PACKAGE_JAVA.addExternalSymbol("JAVA-CLASS");
   public static final Symbol JCALL =
     PACKAGE_JAVA.addExternalSymbol("JCALL");
   public static final Symbol JCALL_RAW =

Modified: branches/scripting/j/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/clos.lisp	(original)
+++ branches/scripting/j/src/org/armedbear/lisp/clos.lisp	Mon Nov  3 22:33:06 2008
@@ -896,6 +896,13 @@
                       (eq (car object) 'quote))
              (setf object (cadr object)))
            (intern-eql-specializer object)))
+	((and (consp specializer)
+              (eq (car specializer) 'java:jclass))
+         (let ((class-name (cadr specializer)))
+           (when (and (consp class-name)
+                      (eq (car class-name) 'quote))
+             (setf class-name (cadr class-name)))
+           (java::%find-java-class class-name)))
         (t
          (error "Unknown specializer: ~S" specializer))))