[armedbear-cvs] r12715 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Fri May 21 22:54:58 UTC 2010
Author: astalla
Date: Fri May 21 18:54:55 2010
New Revision: 12715
Log:
Support for custom defclass options for user-defined metaclasses.
Introduced variable java:*classloader* which holds the classloader used by jclass and friends,
and primitives to create new classloaders and (untested) add new URLs to the classloader at runtime.
Modified:
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/Java.java
trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/src/org/armedbear/lisp/java.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 Fri May 21 18:54:55 2010
@@ -513,6 +513,7 @@
autoload(PACKAGE_JAVA, "%jredefine-method", "RuntimeClass");
autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler");
autoload(PACKAGE_JAVA, "%load-java-class-from-byte-array", "RuntimeClass");
+ autoload(PACKAGE_JAVA, "get-default-classloader", "JavaClassLoader");
autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false);
autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true);
autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true);
Modified: trunk/abcl/src/org/armedbear/lisp/Java.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Java.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Java.java Fri May 21 18:54:55 2010
@@ -59,6 +59,20 @@
return lc.subclassp(java_exception);
}
+ private static final Primitive ENSURE_JAVA_OBJECT = new pf_ensure_java_object();
+ private static final class pf_ensure_java_object extends Primitive
+ {
+ pf_ensure_java_object()
+ {
+ super("ensure-java-object", PACKAGE_JAVA, true, "obj");
+ }
+
+ @Override
+ public LispObject execute(LispObject obj) {
+ return obj instanceof JavaObject ? obj : new JavaObject(obj);
+ }
+ };
+
// ### register-java-exception exception-name condition-symbol => T
private static final Primitive REGISTER_JAVA_EXCEPTION = new pf_register_java_exception();
private static final class pf_register_java_exception extends Primitive
@@ -119,6 +133,7 @@
private static final Primitive JCLASS = new pf_jclass();
private static final class pf_jclass extends Primitive
{
+
pf_jclass()
{
super(Symbol.JCLASS, "name-or-class-ref &optional class-loader",
@@ -128,18 +143,14 @@
@Override
public LispObject execute(LispObject arg)
{
- return JavaObject.getInstance(javaClass(arg));
+ return JavaObject.getInstance(javaClass(arg, JavaClassLoader.getCurrentClassLoader()));
}
@Override
public LispObject execute(LispObject className, LispObject classLoader)
{
ClassLoader loader = (ClassLoader) classLoader.javaInstance(ClassLoader.class);
- if(loader != null) {
- return JavaObject.getInstance(javaClass(className, loader));
- } else {
- return JavaObject.getInstance(javaClass(className));
- }
+ return JavaObject.getInstance(javaClass(className, loader));
}
};
@@ -1176,7 +1187,7 @@
}
private static Class javaClass(LispObject obj) {
- return javaClass(obj, null);
+ return javaClass(obj, JavaClassLoader.getCurrentClassLoader());
}
// Supports Java primitive types too.
@@ -1202,11 +1213,7 @@
return Double.TYPE;
// Not a primitive Java type.
Class c;
- if(classLoader != null) {
- c = classForName(s, classLoader);
- } else {
- c = classForName(s);
- }
+ c = classForName(s, classLoader);
if (c == null)
error(new LispError(s + " does not designate a Java class."));
Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java Fri May 21 18:54:55 2010
@@ -38,8 +38,9 @@
import java.util.Collections;
import java.util.HashSet;
import java.util.Set;
+import java.net.URL;
-public class JavaClassLoader extends ClassLoader {
+public class JavaClassLoader extends java.net.URLClassLoader {
private static JavaClassLoader persistentInstance;
@@ -47,7 +48,15 @@
public JavaClassLoader()
{
- super(JavaClassLoader.class.getClassLoader());
+ this(JavaClassLoader.class.getClassLoader());
+ }
+
+ public JavaClassLoader(ClassLoader parent) {
+ super(new URL[] {}, parent);
+ }
+
+ public JavaClassLoader(URL[] classpath, ClassLoader parent) {
+ super(classpath, parent);
}
public static JavaClassLoader getPersistentInstance()
@@ -117,4 +126,57 @@
}
return null;
}
+
+ @Override
+ public void addURL(URL url) {
+ super.addURL(url);
+ }
+
+ public static final Symbol CLASSLOADER = PACKAGE_JAVA.intern("*CLASSLOADER*");
+
+ private static final Primitive GET_DEFAULT_CLASSLOADER = new pf_get_default_classloader();
+ private static final class pf_get_default_classloader extends Primitive {
+
+ private final LispObject defaultClassLoader = new JavaObject(new JavaClassLoader());
+
+ pf_get_default_classloader() {
+ super("get-default-classloader", PACKAGE_JAVA, true, "");
+ }
+
+ @Override
+ public LispObject execute() {
+ return defaultClassLoader;
+ }
+ };
+
+ private static final Primitive MAKE_CLASSLOADER = new pf_make_classloader();
+ private static final class pf_make_classloader extends Primitive
+ {
+ pf_make_classloader()
+ {
+ super("make-classloader", PACKAGE_JAVA, true, "&optional parent");
+ }
+
+ @Override
+ public LispObject execute() {
+ return new JavaObject(new JavaClassLoader(getCurrentClassLoader()));
+ }
+
+ @Override
+ public LispObject execute(LispObject parent) {
+ return new JavaObject(new JavaClassLoader((ClassLoader) parent.javaInstance(ClassLoader.class)));
+ }
+ };
+
+ public static ClassLoader getCurrentClassLoader() {
+ LispObject classLoader = CLASSLOADER.symbolValueNoThrow();
+ if(classLoader != null) {
+ return (ClassLoader) classLoader.javaInstance(ClassLoader.class);
+ } else {
+ return Lisp.class.getClassLoader();
+ }
+ }
+
+
+
}
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 Fri May 21 18:54:55 2010
@@ -251,10 +251,10 @@
(cdr option))))))
((:documentation :report)
(list (car option) `',(cadr option)))
- (t
- (error 'program-error
- :format-control "invalid DEFCLASS option ~S"
- :format-arguments (list (car option))))))
+ (t (list (car option) `(quote ,(cdr option))))))
+; (error 'program-error
+; :format-control "invalid DEFCLASS option ~S"
+; :format-arguments (list (car option))))))
(defun make-initfunction (initform)
`(function (lambda () ,initform)))
@@ -541,12 +541,13 @@
(eq (%slot-definition-allocation slot) :instance))
(defun make-instance-standard-class (metaclass
+ &rest initargs
&key name direct-superclasses direct-slots
direct-default-initargs
- documentation
- &allow-other-keys)
+ documentation)
(declare (ignore metaclass))
(let ((class (std-allocate-instance +the-standard-class+)))
+ (check-initargs class t initargs)
(%set-class-name name class)
(%set-class-layout nil class)
(%set-class-direct-subclasses () class)
@@ -634,6 +635,7 @@
(t
;; We're redefining the class.
(%make-instances-obsolete old-class)
+ (check-initargs old-class t all-keys)
(apply #'std-after-initialization-for-classes old-class all-keys)
old-class)))
(t
@@ -2376,6 +2378,7 @@
(dolist (option options)
(when (eq (car option) :report)
(setf report (cadr option))
+ (setf options (delete option options :test #'equal))
(return)))
(typecase report
(null
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 Fri May 21 18:54:55 2010
@@ -34,6 +34,15 @@
(require "CLOS")
(require "PRINT-OBJECT")
+(defvar *classloader* (get-default-classloader))
+
+(defun add-url-to-classpath (url &optional (classloader *classloader*))
+ (jcall "addUrl" classloader url))
+
+(defun add-urls-to-classpath (&rest urls)
+ (dolist (url urls)
+ (add-url-to-classpath url)))
+
(defun jregister-handler (object event handler &key data count)
(%jregister-handler object event handler data count))
@@ -191,6 +200,14 @@
(setf (apply #'jarray-ref jarray (row-major-to-index dimensions i)) (row-major-aref array i))
(apply #'(setf jarray-ref) (row-major-aref array i) jarray (row-major-to-index dimensions i))))))
+(defun jnew-array-from-list (element-type list)
+ (let ((jarray (jnew-array element-type (length list)))
+ (i 0))
+ (dolist (x list)
+ (setf (jarray-ref jarray i) x
+ i (1+ i)))
+ jarray))
+
(defun jclass-constructors (class)
"Returns a vector of constructors for CLASS"
(jcall (jmethod "java.lang.Class" "getConstructors") (jclass class)))
More information about the armedbear-cvs
mailing list