Changeset 12715

Timestamp:

05/21/10 22:54:55 (13 years ago)

Author:

astalla

Message:

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.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (1 diff)
• Java.java (modified) (6 diffs)
• JavaClassLoader.java (modified) (3 diffs)
• clos.lisp (modified) (4 diffs)
• java.lisp (modified) (2 diffs)

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

@@ -514 +514 @@
         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);

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

@@ -60 +60 @@
     }
 
+    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();
@@ -120 +134 @@
     private static final class pf_jclass extends Primitive 
     {
+
         pf_jclass() 
         {
@@ -129 +144 @@
         public LispObject execute(LispObject arg)
         {
-            return JavaObject.getInstance(javaClass(arg));
+      return JavaObject.getInstance(javaClass(arg, JavaClassLoader.getCurrentClassLoader()));
         }
 
@@ -136 +151 @@
         {
       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));
         }
     };
@@ -1177 +1188 @@
 
     private static Class javaClass(LispObject obj) {
-  return javaClass(obj, null);
+  return javaClass(obj, JavaClassLoader.getCurrentClassLoader());
     }
 
@@ -1203 +1214 @@
             // 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."));

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

@@ -39 +39 @@
 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;
@@ -48 +49 @@
     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);
     }
 
@@ -118 +127 @@
         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();
+  }
+    }
+
+
+
 }

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

@@ -252 +252 @@
     ((: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)
@@ -542 +542 @@
 
 (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)
@@ -635 +636 @@
                   ;; 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)))
@@ -2377 +2379 @@
       (when (eq (car option) :report)
         (setf report (cadr option))
+  (setf options (delete option options :test #'equal))
         (return)))
     (typecase report

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

@@ -35 +35 @@
 (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 +200 @@
         (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)