Changeset 12583

Timestamp:

04/08/10 19:44:14 (14 years ago)

Author:

astalla

Message:

JAVA-CLASS metaclass reimplemented in Lisp.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (1 diff)
• JavaClass.java (deleted)
• JavaObject.java (modified) (4 diffs)
• StandardClass.java (modified) (2 diffs)
• autoloads.lisp (modified) (1 diff)
• clos.lisp (modified) (2 diffs)
• java.lisp (modified) (2 diffs)
• known-symbols.lisp (modified) (1 diff)
• print-object.lisp (modified) (3 diffs)

trunk/abcl/src/org/armedbear/lisp/Autoload.java

@@ -506 +506 @@
         autoload(PACKAGE_EXT, "string-position", "StringFunctions");
         autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy");
-        autoload(PACKAGE_JAVA, "%find-java-class", "JavaClass");
+        autoload(PACKAGE_JAVA, "%find-java-class", "JavaObject");
+        autoload(PACKAGE_JAVA, "%register-java-class", "JavaObject");
         autoload(PACKAGE_JAVA, "%jmake-invocation-handler", "JProxy");
         autoload(PACKAGE_JAVA, "%jmake-proxy", "JProxy");

trunk/abcl/src/org/armedbear/lisp/JavaObject.java

@@ -39 +39 @@
 import java.lang.reflect.Field;
 import java.math.BigInteger;
-import java.util.ArrayList;
-import java.util.Collection;
-import java.util.HashSet;
-import java.util.LinkedList;
-import java.util.Set;
+import java.util.*;
 
 public final class JavaObject extends LispObject {
@@ -54 +50 @@
       obj != null ? Java.maybeBoxClass(obj.getClass()) : null;
     }
+
+    public static final Symbol JAVA_CLASS_JCLASS = PACKAGE_JAVA.intern("JAVA-CLASS-JCLASS");
+    public static final Symbol JAVA_CLASS = PACKAGE_JAVA.intern("JAVA-CLASS");
+    public static final Symbol ENSURE_JAVA_CLASS = PACKAGE_JAVA.intern("ENSURE-JAVA-CLASS");
 
     /**
@@ -88 +88 @@
                 return BuiltInClass.JAVA_OBJECT;
         } else {
-                return JavaClass.findJavaClass(obj.getClass());
+      return ENSURE_JAVA_CLASS.execute(new JavaObject(obj.getClass()));
         }
     }
 
     @Override
-    public LispObject typep(LispObject type)
-    {
+    public LispObject typep(LispObject type) {
         if (type == Symbol.JAVA_OBJECT)
             return T;
         if (type == BuiltInClass.JAVA_OBJECT)
             return T;
-        if(type instanceof JavaClass && obj != null) {
-                return ((JavaClass) type).getJavaClass().isAssignableFrom(obj.getClass()) ? T : NIL;
-        }
+  if(type.typep(LispClass.findClass(JAVA_CLASS, false)) != NIL) {
+      if(obj != null) {
+    Class c = (Class) JAVA_CLASS_JCLASS.execute(type).javaInstance();
+    return c.isAssignableFrom(obj.getClass()) ? T : NIL;
+      } else {
+    return T;
+      }
+  }
         return super.typep(type);
     }
@@ -523 +527 @@
         }
     };
+
+    //JAVA-CLASS support
+
+    //There is no point for this Map to be weak since values keep a reference to the corresponding
+    //key (the Java class). This should not be a problem since Java classes are limited in number - 
+    //if they grew indefinitely, the JVM itself would crash.
+    private static final Map<Class<?>, LispObject> javaClassMap = new HashMap<Class<?>, LispObject>();
+
+    public static LispObject registerJavaClass(Class<?> javaClass, LispObject classMetaObject) {
+  synchronized (javaClassMap) {
+      javaClassMap.put(javaClass, classMetaObject);
+      return classMetaObject;
+  }
+    }
+
+    public static LispObject findJavaClass(Class<?> javaClass) {
+  synchronized (javaClassMap) {
+      LispObject c = javaClassMap.get(javaClass);
+      if (c != null) {
+    return c;
+      } else {
+    return NIL;
+      }
+  }
+    }
+
+    private static final Primitive _FIND_JAVA_CLASS = new Primitive("%find-java-class", PACKAGE_JAVA, false, "class-name-or-class") {
+      public LispObject execute(LispObject arg) {
+    try {
+        if(arg instanceof AbstractString) {
+      return findJavaClass(Class.forName((String) arg.getStringValue()));
+        } else {
+      return findJavaClass((Class<?>) arg.javaInstance());
+        }
+    } catch (ClassNotFoundException e) {
+        return error(new LispError("Cannot find Java class " + arg.getStringValue()));
+    }
+      }
+      
+  };
+
+    private static final Primitive _REGISTER_JAVA_CLASS = new Primitive("%register-java-class", PACKAGE_JAVA, false, "jclass class-metaobject") {
+      public LispObject execute(LispObject jclass, LispObject classMetaObject) {
+    return registerJavaClass((Class<?>) jclass.javaInstance(), classMetaObject);
+      }
+      
+  };
+
 }

trunk/abcl/src/org/armedbear/lisp/StandardClass.java

@@ -396 +396 @@
     addStandardClass(Symbol.BUILT_IN_CLASS, list(CLASS));
 
-  public static final StandardClass JAVA_CLASS =
-      addStandardClass(Symbol.JAVA_CLASS, list(CLASS));
-  
   public static final StandardClass FORWARD_REFERENCED_CLASS =
     addStandardClass(Symbol.FORWARD_REFERENCED_CLASS, list(CLASS));
@@ -549 +546 @@
     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);

trunk/abcl/src/org/armedbear/lisp/autoloads.lisp

@@ -280 +280 @@
 (export 'jruntime-class-exists-p "JAVA")
 (autoload 'jruntime-class-exists-p "runtime-class")
+(export 'ensure-java-class "JAVA")
+(autoload 'ensure-java-class "java")
 
 ;; Profiler.

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

@@ -579 +579 @@
   (getf canonical-slot :name))
 
-(defvar *extensible-built-in-classes* (list (find-class 'sequence)))
+(defvar *extensible-built-in-classes* (list (find-class 'sequence) (find-class 'java:java-object)))
 
 (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
@@ -972 +972 @@
   ((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)))
+         (let ((jclass (eval specializer)))
+     (java::ensure-java-class jclass)))
         (t
          (error "Unknown specializer: ~S" specializer))))

trunk/abcl/src/org/armedbear/lisp/java.lisp

@@ -33 +33 @@
 
 (require "CLOS")
+(require "PRINT-OBJECT")
 
 (defun jregister-handler (object event handler &key data count)
@@ -309 +310 @@
   (%jset-property-value obj prop value))
 
-(provide "JAVA-EXTENSIONS")
+;;; print-object
+
+(defmethod print-object ((obj java:java-object) stream)
+  (write-string (sys::%write-to-string obj) stream))
+
+(defmethod print-object ((e java:java-exception) stream)
+  (if *print-escape*
+      (print-unreadable-object (e stream :type t :identity t)
+        (format stream "~A"
+                (java:jcall (java:jmethod "java.lang.Object" "toString")
+                            (java:java-exception-cause e))))
+      (format stream "Java exception '~A'."
+              (java:jcall (java:jmethod "java.lang.Object" "toString")
+                          (java:java-exception-cause e)))))
+
+;;; JAVA-CLASS support
+
+(defclass java-class (standard-class)
+  ((jclass :initarg :java-class
+     :initform (error "class is required")
+     :reader java-class-jclass)))
+
+(defun ensure-java-class (jclass)
+  (let ((class (%find-java-class jclass)))
+    (if class
+  class
+  (%register-java-class
+   jclass (mop::ensure-class (make-symbol (jclass-name jclass))
+           :metaclass (find-class 'java-class)
+           :direct-superclasses (if (jclass-superclass-p jclass (jclass "java.lang.Object"))
+                  (list (find-class 'java-object))
+                  (mapcar #'ensure-java-class
+                    (delete nil
+                      (concatenate 'list (list (jclass-superclass jclass))
+                       (jclass-interfaces jclass)))))
+           :java-class jclass)))))
+    
+(defmethod make-instance ((class java-class) &rest initargs &key &allow-other-keys)
+  (declare (ignore initargs))
+  (error "make-instance not supported for ~S" class))
+
+(provide "JAVA")

trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp

@@ -32 +32 @@
 (in-package #:system)
 
+(require "JAVA")
+
 (export '(lookup-known-symbol))
 

trunk/abcl/src/org/armedbear/lisp/print-object.lisp

@@ -33 +33 @@
 
 (require 'clos)
-(require 'java)
 
 (when (autoloadp 'print-object)
@@ -50 +49 @@
     (format stream "~S" (class-name (class-of object))))
   object)
-
-(defmethod print-object ((obj java:java-object) stream)
-  (write-string (%write-to-string obj) stream))
-
-(defmethod print-object ((class java:java-class) stream)
-  (write-string (%write-to-string class) stream))
 
 (defmethod print-object ((class class) stream)
@@ -124 +117 @@
       (format stream "The variable ~S is unbound." (cell-error-name x))))
 
-(defmethod print-object ((e java:java-exception) stream)
-  (if *print-escape*
-      (print-unreadable-object (e stream :type t :identity t)
-        (format stream "~A"
-                (java:jcall (java:jmethod "java.lang.Object" "toString")
-                            (java:java-exception-cause e))))
-      (format stream "Java exception '~A'."
-              (java:jcall (java:jmethod "java.lang.Object" "toString")
-                          (java:java-exception-cause e)))))
-
 (provide 'print-object)