[armedbear-cvs] r12583 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Thu Apr 8 19:44:14 UTC 2010
Author: astalla
Date: Thu Apr 8 15:44:14 2010
New Revision: 12583
Log:
JAVA-CLASS metaclass reimplemented in Lisp.
Removed:
trunk/abcl/src/org/armedbear/lisp/JavaClass.java
Modified:
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/JavaObject.java
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/java.lisp
trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp
trunk/abcl/src/org/armedbear/lisp/print-object.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Thu Apr 8 15:44:14 2010
@@ -505,7 +505,8 @@
autoload(PACKAGE_EXT, "string-find", "StringFunctions");
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");
autoload(PACKAGE_JAVA, "%jnew-runtime-class", "RuntimeClass");
Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/JavaObject.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Thu Apr 8 15:44:14 2010
@@ -38,11 +38,7 @@
import java.lang.reflect.Array;
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 {
final Object obj;
@@ -54,6 +50,10 @@
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");
+
/**
* Constructs a Java Object with the given intended class, used to access
* the object reflectively. If the class represents a primitive type,
@@ -87,20 +87,24 @@
if(obj == null) {
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);
}
@@ -522,4 +526,52 @@
return LispThread.currentThread().nothing();
}
};
+
+ //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);
+ }
+
+ };
+
}
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Thu Apr 8 15:44:14 2010
@@ -395,9 +395,6 @@
public static final StandardClass BUILT_IN_CLASS =
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));
@@ -548,8 +545,6 @@
list(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: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Apr 8 15:44:14 2010
@@ -279,6 +279,8 @@
(autoload 'jredefine-method "runtime-class")
(export 'jruntime-class-exists-p "JAVA")
(autoload 'jruntime-class-exists-p "runtime-class")
+(export 'ensure-java-class "JAVA")
+(autoload 'ensure-java-class "java")
;; Profiler.
(in-package "PROFILER")
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Apr 8 15:44:14 2010
@@ -578,7 +578,7 @@
(defun canonical-slot-name (canonical-slot)
(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)
;; Check for duplicate slots.
@@ -971,11 +971,8 @@
(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)))
+ (let ((jclass (eval specializer)))
+ (java::ensure-java-class jclass)))
(t
(error "Unknown specializer: ~S" specializer))))
Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/java.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/java.lisp Thu Apr 8 15:44:14 2010
@@ -32,6 +32,7 @@
(in-package "JAVA")
(require "CLOS")
+(require "PRINT-OBJECT")
(defun jregister-handler (object event handler &key data count)
(%jregister-handler object event handler data count))
@@ -308,4 +309,45 @@
(defun (setf jproperty-value) (value obj prop)
(%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")
Modified: trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp Thu Apr 8 15:44:14 2010
@@ -31,6 +31,8 @@
(in-package #:system)
+(require "JAVA")
+
(export '(lookup-known-symbol))
(let ((symbols (make-hash-table :test 'eq :size 2048)))
Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/print-object.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Thu Apr 8 15:44:14 2010
@@ -32,7 +32,6 @@
(in-package #:system)
(require 'clos)
-(require 'java)
(when (autoloadp 'print-object)
(fmakunbound 'print-object))
@@ -50,12 +49,6 @@
(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)
(print-unreadable-object (class stream :identity t)
(format stream "~S ~S"
@@ -123,14 +116,4 @@
(cell-error-name x)))
(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)
More information about the armedbear-cvs
mailing list