From astalla at common-lisp.net Thu Jul 1 20:57:12 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 01 Jul 2010 16:57:12 -0400 Subject: [armedbear-cvs] r12773 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu Jul 1 16:57:11 2010 New Revision: 12773 Log: Added classpath manipulation primitives: java:add-to-classpath and java:dump-classpath Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java trunk/abcl/src/org/armedbear/lisp/Pathname.java 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 Jul 1 16:57:11 2010 @@ -514,6 +514,9 @@ 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_JAVA, "make-classloader", "JavaClassLoader"); + autoload(PACKAGE_JAVA, "add-to-classpath", "JavaClassLoader"); + autoload(PACKAGE_JAVA, "dump-classpath", "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/JavaClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java Thu Jul 1 16:57:11 2010 @@ -39,8 +39,9 @@ import java.util.HashSet; import java.util.Set; import java.net.URL; +import java.net.URLClassLoader; -public class JavaClassLoader extends java.net.URLClassLoader { +public class JavaClassLoader extends URLClassLoader { private static JavaClassLoader persistentInstance; @@ -168,6 +169,92 @@ } }; + private static final Primitive DUMP_CLASSPATH = new pf_dump_classpath(); + private static final class pf_dump_classpath extends Primitive + { + pf_dump_classpath() + { + super("dump-classpath", PACKAGE_JAVA, true, "&optional classloader"); + } + + @Override + public LispObject execute() { + return execute(new JavaObject(getCurrentClassLoader())); + } + + @Override + public LispObject execute(LispObject classloader) { + LispObject list = NIL; + Object o = classloader.javaInstance(); + while(o instanceof ClassLoader) { + ClassLoader cl = (ClassLoader) o; + list = list.push(dumpClassPath(cl)); + o = cl.getParent(); + } + return list.nreverse(); + } + }; + + private static final Primitive ADD_TO_CLASSPATH = new pf_add_to_classpath(); + private static final class pf_add_to_classpath extends Primitive + { + pf_add_to_classpath() + { + super("add-to-classpath", PACKAGE_JAVA, true, "jar-or-jars &optional (classloader (get-current-classloader))"); + } + + @Override + public LispObject execute(LispObject jarOrJars) { + return execute(jarOrJars, new JavaObject(getCurrentClassLoader())); + } + + @Override + public LispObject execute(LispObject jarOrJars, LispObject classloader) { + Object o = classloader.javaInstance(); + if(o instanceof JavaClassLoader) { + JavaClassLoader jcl = (JavaClassLoader) o; + if(jarOrJars instanceof Cons) { + while(jarOrJars != NIL) { + addURL(jcl, jarOrJars.car()); + jarOrJars = jarOrJars.cdr(); + } + } else { + addURL(jcl, jarOrJars); + } + return T; + } else { + return error(new TypeError(o + " must be an instance of " + JavaClassLoader.class.getName())); + } + } + }; + + protected static void addURL(JavaClassLoader jcl, LispObject jar) { + try { + if(jar instanceof Pathname) { + jcl.addURL(((Pathname) jar).toURL()); + } else if(jar instanceof AbstractString) { + jcl.addURL(new Pathname(jar.toString()).toURL()); + } else { + error(new TypeError(jar + " must be a pathname designator")); + } + } catch(java.net.MalformedURLException e) { + error(new LispError(jar + " is not a valid URL")); + } + } + + + public static LispObject dumpClassPath(ClassLoader o) { + if(o instanceof URLClassLoader) { + LispObject list = NIL; + for(URL u : ((URLClassLoader) o).getURLs()) { + list = list.push(new Pathname(u)); + } + return new Cons(new JavaObject(o), list.nreverse()); + } else { + return new JavaObject(o); + } + } + public static ClassLoader getCurrentClassLoader() { LispObject classLoader = CLASSLOADER.symbolValueNoThrow(); if(classLoader != null) { Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Thu Jul 1 16:57:11 2010 @@ -2342,6 +2342,22 @@ return getNamestring(); } + public URL toURL() throws MalformedURLException { + if(isURL()) { + return new URL(getNamestring()); + } else { + return toFile().toURL(); + } + } + + public File toFile() { + if(!isURL()) { + return new File(getNamestring()); + } else { + throw new RuntimeException(this + " does not represent a file"); + } + } + static { LispObject obj = Symbol.DEFAULT_PATHNAME_DEFAULTS.getSymbolValue(); Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(coerceToPathname(obj)); From astalla at common-lisp.net Thu Jul 1 21:02:46 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 01 Jul 2010 17:02:46 -0400 Subject: [armedbear-cvs] r12774 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu Jul 1 17:02:45 2010 New Revision: 12774 Log: Added support for implementing multiple interfaces using jmake-proxy Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JProxy.java Thu Jul 1 17:02:45 2010 @@ -210,26 +210,26 @@ private static final Primitive _JMAKE_PROXY = new Primitive("%jmake-proxy", PACKAGE_JAVA, false, - "interface invocation-handler") { + "interfaces invocation-handler") { public LispObject execute(final LispObject[] args) { int length = args.length; if (length != 3) { return error(new WrongNumberOfArgumentsException(this)); } - if(!(args[0] instanceof JavaObject) || - !(((JavaObject) args[0]).javaInstance() instanceof Class)) { - return error(new TypeError(args[0], new SimpleString(Class.class.getName()))); + if(!(args[0] instanceof Cons)) { + return error(new TypeError(args[0], new SimpleString("CONS"))); } - if(!(args[1] instanceof JavaObject) || - !(((JavaObject) args[1]).javaInstance() instanceof InvocationHandler)) { - return error(new TypeError(args[1], new SimpleString(InvocationHandler.class.getName()))); - } - Class iface = (Class) ((JavaObject) args[0]).javaInstance(); - InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance(); + Class[] ifaces = new Class[args[0].length()]; + LispObject ifList = args[0]; + for(int i = 0; i < ifaces.length; i++) { + ifaces[i] = ifList.car().javaInstance(Class.class); + ifList = ifList.cdr(); + } + InvocationHandler invocationHandler = ((JavaObject) args[1]).javaInstance(InvocationHandler.class); Object proxy = Proxy.newProxyInstance( - iface.getClassLoader(), - new Class[] { iface }, + JavaClassLoader.getCurrentClassLoader(), + ifaces, invocationHandler); synchronized(proxyMap) { proxyMap.put(proxy, args[2]); 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 Jul 1 17:02:45 2010 @@ -92,15 +92,21 @@ (fmakunbound 'jmake-proxy)) (defgeneric jmake-proxy (interface implementation &optional lisp-this) - (:documentation "Returns a proxy Java object implementing the provided interface using methods implemented in Lisp - typically closures, but implementations are free to provide other mechanisms. You can pass an optional 'lisp-this' object that will be passed to the implementing methods as their first argument. If you don't provide this object, NIL will be used. The second argument of the Lisp methods is the name of the Java method being implemented. This has the implication that overloaded methods are merged, so you have to manually discriminate them if you want to. The remaining arguments are java-objects wrapping the method's parameters.")) + (:documentation "Returns a proxy Java object implementing the provided interface(s) using methods implemented in Lisp - typically closures, but implementations are free to provide other mechanisms. You can pass an optional 'lisp-this' object that will be passed to the implementing methods as their first argument. If you don't provide this object, NIL will be used. The second argument of the Lisp methods is the name of the Java method being implemented. This has the implication that overloaded methods are merged, so you have to manually discriminate them if you want to. The remaining arguments are java-objects wrapping the method's parameters.")) + +(defun canonicalize-jproxy-interfaces (ifaces) + (if (listp ifaces) + (mapcar #'jclass ifaces) + (list (jclass ifaces)))) + (defmethod jmake-proxy (interface invocation-handler &optional lisp-this) "Basic implementation that directly uses an invocation handler." - (%jmake-proxy (jclass interface) invocation-handler lisp-this)) + (%jmake-proxy (canonicalize-jproxy-interfaces interface) invocation-handler lisp-this)) (defmethod jmake-proxy (interface (implementation function) &optional lisp-this) "Implements a Java interface forwarding method calls to a Lisp function." - (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation) lisp-this)) + (%jmake-proxy (canonicalize-jproxy-interfaces interface) (jmake-invocation-handler implementation) lisp-this)) (defmethod jmake-proxy (interface (implementation package) &optional lisp-this) "Implements a Java interface mapping Java method names to symbols in a given package. javaMethodName is mapped to a JAVA-METHOD-NAME symbol. An error is signaled if no such symbol exists in the package, or if the symbol exists but does not name a function." @@ -114,7 +120,7 @@ (setf last-lower-p (not upper-p)) (princ (char-upcase char) str))) name))))) - (%jmake-proxy (jclass interface) + (%jmake-proxy (canonicalize-jproxy-interfaces interface) (jmake-invocation-handler (lambda (obj method &rest args) (let ((sym (find-symbol @@ -133,7 +139,7 @@ (defmethod jmake-proxy (interface (implementation hash-table) &optional lisp-this) "Implements a Java interface using closures in an hash-table keyed by Java method name." - (%jmake-proxy (jclass interface) + (%jmake-proxy (canonicalize-jproxy-interfaces interface) (jmake-invocation-handler (lambda (obj method &rest args) (let ((fn (gethash method implementation))) From mevenson at common-lisp.net Fri Jul 2 09:42:26 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 02 Jul 2010 05:42:26 -0400 Subject: [armedbear-cvs] r12775 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jul 2 05:42:24 2010 New Revision: 12775 Log: Fix compiler errors. Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JProxy.java Fri Jul 2 05:42:24 2010 @@ -223,10 +223,10 @@ Class[] ifaces = new Class[args[0].length()]; LispObject ifList = args[0]; for(int i = 0; i < ifaces.length; i++) { - ifaces[i] = ifList.car().javaInstance(Class.class); + ifaces[i] = (Class) ifList.car().javaInstance(Class.class); ifList = ifList.cdr(); } - InvocationHandler invocationHandler = ((JavaObject) args[1]).javaInstance(InvocationHandler.class); + InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance(InvocationHandler.class); Object proxy = Proxy.newProxyInstance( JavaClassLoader.getCurrentClassLoader(), ifaces, From ehuelsmann at common-lisp.net Sat Jul 3 20:35:43 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 03 Jul 2010 16:35:43 -0400 Subject: [armedbear-cvs] r12776 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 3 16:35:42 2010 New Revision: 12776 Log: More pool functions. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sat Jul 3 16:35:42 2010 @@ -168,8 +168,10 @@ (defstruct pool - (count 1) ;; "A constant pool entry is considered valid if it has - ;; an index greater than 0 (zero) and less than pool-count" + ;; `count' contains a reference to the last-used slot (0 being empty) + ;; "A constant pool entry is considered valid if it has + ;; an index greater than 0 (zero) and less than pool-count" + (count 0) entries-list ;; the entries hash stores raw values, except in case of string and ;; utf8, because both are string values @@ -274,6 +276,40 @@ (push entry (pool-entries-list pool))) (constant-index entry))) +(defun pool-add-int (pool int) + (let ((entry (gethash (cons 3 int) (pool-entries pool)))) + (unless entry + (setf entry (make-constant-int (incf (pool-count pool)) int) + (gethash (cons 3 int) (pool-entries pool)) entry) + (push entry (pool-entries-list pool))) + (constant-index entry))) + +(defun pool-add-float (pool float) + (let ((entry (gethash (cons 4 float) (pool-entries pool)))) + (unless entry + (setf entry (make-constant-float (incf (pool-count pool)) float) + (gethash (cons 4 float) (pool-entries pool)) entry) + (push entry (pool-entries-list pool))) + (constant-index entry))) + +(defun pool-add-long (pool long) + (let ((entry (gethash (cons 5 long) (pool-entries pool)))) + (unless entry + (setf entry (make-constant-long (incf (pool-count pool)) long) + (gethash (cons 5 long) (pool-entries pool)) entry) + (push entry (pool-entries-list pool)) + (incf (pool-count pool))) ;; double index increase; long takes 2 slots + (constant-index entry))) + +(defun pool-add-double (pool double) + (let ((entry (gethash (cons 6 double) (pool-entries pool)))) + (unless entry + (setf entry (make-constant-double (incf (pool-count pool)) double) + (gethash (cons 6 double) (pool-entries pool)) entry) + (push entry (pool-entries-list pool)) + (incf (pool-count pool))) ;; double index increase; 'double' takes 2 slots + (constant-index entry))) + (defun pool-add-name/type (pool name type) (let ((entry (gethash (cons name type) (pool-entries pool))) (internal-type (if (listp type) From ehuelsmann at common-lisp.net Sat Jul 3 21:40:18 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 03 Jul 2010 17:40:18 -0400 Subject: [armedbear-cvs] r12777 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 3 17:40:17 2010 New Revision: 12777 Log: More pool management and serialization. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sat Jul 3 17:40:17 2010 @@ -199,9 +199,23 @@ (tag 7))) name-index) -(defstruct (constant-member-ref (:include constant)) - class - name/type) +(defstruct (constant-member-ref (:constructor + %make-constant-member-ref + (tag index class-index name/type-index)) + (:include constant)) + class-index + name/type-index) + +(declaim (inline make-constant-field-ref make-constant-method-ref + make-constant-interface-method-ref)) +(defun make-constant-field-ref (index class-index name/type-index) + (%make-constant-member-ref 9 index class-index name/type-index)) + +(defun make-constant-method-ref (index class-index name/type-index) + (%make-constant-member-ref 10 index class-index name/type-index)) + +(defun make-constant-interface-method-ref (index class-index name/type-index) + (%make-constant-member-ref 11 index class-index name/type-index)) (defstruct (constant-string (:constructor make-constant-string (index value-index)) @@ -256,16 +270,38 @@ (push entry (pool-entries-list pool))) (constant-index entry))) -(defun pool-add-member-ref (pool class name type) +(defun pool-add-field-ref (pool class name type) + (let ((entry (gethash (acons name type class) (pool-entries pool)))) + (unless entry + (setf entry (make-constant-field-ref (incf (pool-count pool)) + (pool-add-class pool class) + (pool-add-name/type pool name type)) + (gethash (acons name type class) (pool-entries pool)) entry) + (push entry (pool-entries-list pool))) + (constant-index entry))) + +(defun pool-add-method-ref (pool class name type) (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (setf entry (make-constant-member-ref (incf (pool-count pool)) + (setf entry (make-constant-method-ref (incf (pool-count pool)) (pool-add-class pool class) (pool-add-name/type pool name type)) (gethash (acons name type class) (pool-entries pool)) entry) (push entry (pool-entries-list pool))) (constant-index entry))) +(defun pool-add-interface-method-ref (pool class name type) + (let ((entry (gethash (acons name type class) (pool-entries pool)))) + (unless entry + (setf entry + (make-constant-interface-method-ref (incf (pool-count pool)) + (pool-add-class pool class) + (pool-add-name/type pool + name type)) + (gethash (acons name type class) (pool-entries pool)) entry) + (push entry (pool-entries-list pool))) + (constant-index entry))) + (defun pool-add-string (pool string) (let ((entry (gethash (cons 8 string) ;; 8 == string-tag (pool-entries pool)))) @@ -369,7 +405,8 @@ (setf (class-file-access-flags class) (map-flags (class-file-access-flags class))) - ;; (finalize-class-name ) + (setf (class-file-class-name class) + (pool-add-class (class-name-internal (class-file-class-name class)))) ;; (finalize-interfaces) (dolist (field (class-file-fields class)) (finalize-field field class)) @@ -426,13 +463,19 @@ ((3 4) ; int (write-u4 (constant-float/int-value entry) stream)) ((5 6) ; long double - (write-u4 (second entry) stream) - (write-u4 (third entry) stream)) - ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType - (write-u2 (second entry) stream) - (write-u2 (third entry) stream)) - ((7 8) ; class string + (write-u4 (logand (ash (constant-double/long-value entry) -32) + #xFFFFffff) stream) + (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) stream)) + ((9 10 11) ; fieldref methodref InterfaceMethodref + (write-u2 (constant-member-ref-class-index entry) stream) + (write-u2 (constant-member-ref-name/type-index entry) stream)) + (12 ; nameAndType + (write-u2 (constant-name/type-name-index entry) stream) + (write-u2 (constant-name/type-descriptor-index entry) stream)) + (7 ; class (write-u2 (constant-class-name-index entry) stream)) + (8 ; string + (write-u2 (constant-string-value-index entry) stream)) (t (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))) @@ -517,15 +560,8 @@ "") (t name))) -(defun !make-method-descriptor (name return &rest args) - (apply #'concatenate (append (list 'string (map-method-name name) "(") - (mapcar #'map-primitive-type args) - (list ")" return)))) - (defun !make-method (name return args &key (flags '(:public))) - (setf name (map-method-name name)) - (%make-method :descriptor (apply #'make-method-descriptor - name return args) + (%make-method :descriptor (cons return args) :access-flags flags :name name :arg-count (if (member :static flags) From ehuelsmann at common-lisp.net Sat Jul 3 22:05:14 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 03 Jul 2010 18:05:14 -0400 Subject: [armedbear-cvs] r12778 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 3 18:05:13 2010 New Revision: 12778 Log: Managing field/method/attribute attributes. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sat Jul 3 18:05:13 2010 @@ -390,12 +390,22 @@ (push method (class-file-methods class))) (defun class-methods-by-name (class name) - (remove (map-method-name name) (class-file-methods class) + (remove name (class-file-methods class) :test-not #'string= :key #'method-name)) -(defun class-method (class descriptor) - (find descriptor (class-file-methods class) - :test #'string= :key #'method-name)) +(defun class-method (class name return &rest args) + (let ((return-and-args (cons return args))) + (find-if #'(lambda (c) + (and (string= (method-name c) name) + (equal (method-descriptor c) return-and-args))) + (class-file-methods class)))) + +(defun class-add-attribute (class attribute) + (push atttribute (class-file-attributes class))) + +(defun class-attribute (class name) + (find name (class-file-attributes class) + :test #'string= :key #'attribute-name)) (defun finalize-class-file (class) @@ -521,9 +531,12 @@ :name name :descriptor type)) -(defun add-field-attribute (field attribute) +(defun field-add-attribute (field attribute) (push attribute (field-attributes field))) +(defun field-attribute (field name) + (find name (field-attributes field) + :test #'string= :key #'attribute-name)) (defun finalize-field (field class) (let ((pool (class-file-constants class))) From ehuelsmann at common-lisp.net Sat Jul 3 22:15:28 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 03 Jul 2010 18:15:28 -0400 Subject: [armedbear-cvs] r12779 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 3 18:15:26 2010 New Revision: 12779 Log: 'Code' attribute creation. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sat Jul 3 18:15:26 2010 @@ -560,8 +560,6 @@ name descriptor attributes - arg-count ;; not in the class file, - ;; but required for setting up CODE attribute ) @@ -576,14 +574,18 @@ (defun !make-method (name return args &key (flags '(:public))) (%make-method :descriptor (cons return args) :access-flags flags - :name name - :arg-count (if (member :static flags) - (length args) - (1+ (length args))))) ;; implicit 'this' + :name name)) (defun method-add-attribute (method attribute) (push attribute (method-attributes method))) +(defun method-add-code (method) + "Creates an (empty) 'Code' attribute for the method." + (method-add-attribute + (make-code-attribute (+ (length args) + (if (member :static (method-access-flags method)) + 0 1))))) ;; 1 == implicit 'this' + (defun method-attribute (method name) (find name (method-attributes method) :test #'string= :key #'attribute-name)) @@ -676,8 +678,10 @@ (write-u1 (svref code-array i) stream))) (write-attributes (code-attributes code) stream)) -(defun make-code-attribute (method) - (%make-code-attribute :max-locals (method-arg-count method))) +(defun make-code-attribute (arg-count) + "Creates an empty 'Code' attribute for a method which takes +`arg-count` parameters, including the implicit `this` parameter." + (%make-code-attribute :max-locals arg-count)) (defun code-add-attribute (code attribute) (push attribute (code-attributes code))) From mevenson at common-lisp.net Sun Jul 4 06:43:53 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 04 Jul 2010 02:43:53 -0400 Subject: [armedbear-cvs] r12780 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Jul 4 02:43:52 2010 New Revision: 12780 Log: Small non-functional code and comment cleanups. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sun Jul 4 02:43:52 2010 @@ -606,8 +606,8 @@ // the namestring." 19.2.2.2.3.1 if (host != NIL) { Debug.assertTrue(host instanceof AbstractString - || host instanceof Cons); - if (host instanceof Cons) { + || isURL()); + if (isURL()) { LispObject scheme = Symbol.GETF.execute(host, SCHEME, NIL); LispObject authority = Symbol.GETF.execute(host, AUTHORITY, NIL); Debug.assertTrue(scheme != NIL); @@ -631,7 +631,7 @@ } if (device == NIL) { } else if (device == Keyword.UNSPECIFIC) { - } else if (device instanceof Cons) { + } else if (isJar()) { LispObject[] jars = ((Cons) device).copyToArray(); StringBuilder prefix = new StringBuilder(); for (int i = 0; i < jars.length; i++) { @@ -643,9 +643,6 @@ sb.append("!/"); } sb = prefix.append(sb); - } else if (device instanceof AbstractString - && device.getStringValue().startsWith("jar:")) { - sb.append(device.getStringValue()); } else if (device instanceof AbstractString) { sb.append(device.getStringValue()); if (this instanceof LogicalPathname @@ -723,7 +720,7 @@ } } namestring = sb.toString(); - // XXX Decide when this is necessary + // XXX Decide if this is necessary // if (isURL()) { // namestring = Utilities.uriEncode(namestring); // } @@ -1236,7 +1233,7 @@ namestring = file.getCanonicalPath(); } catch (IOException e) { Debug.trace("Failed to make a Pathname from " - + "." + file + "'"); + + "'" + file + "'"); return null; } return new Pathname(namestring); @@ -1290,7 +1287,7 @@ if (host == NIL) { host = defaults.host; } - if (directory == NIL && defaults != null) { + if (directory == NIL) { directory = defaults.directory; } if (!deviceSupplied) { @@ -2084,7 +2081,8 @@ if (pathname.isURL()) { result = new URL(pathname.getNamestring()); } else { - // XXX ensure that we have cannonical path. + // XXX Properly encode Windows drive letters and UNC paths + // XXX ensure that we have cannonical path? result = new URL("file://" + pathname.getNamestring()); } } catch (MalformedURLException e) { From ehuelsmann at common-lisp.net Sun Jul 4 07:49:15 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Jul 2010 03:49:15 -0400 Subject: [armedbear-cvs] r12781 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 4 03:49:14 2010 New Revision: 12781 Log: Small fixes found by test-writing. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Jul 4 03:49:14 2010 @@ -153,17 +153,17 @@ |# (defun internal-field-type (field-type) - (if (keywordp field-type) + (if (symbolp field-type) (map-primitive-type field-type) (class-name-internal field-type))) (defun internal-field-ref (field-type) - (if (keywordp field-type) + (if (symbolp field-type) (map-primitive-type field-type) (class-ref field-type))) (defun descriptor (return-type &rest argument-types) - (format nil "(~{~A~}~A)" (mapcar #'internal-field-ref argument-types) + (format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types) (internal-field-type return-type))) @@ -401,7 +401,7 @@ (class-file-methods class)))) (defun class-add-attribute (class attribute) - (push atttribute (class-file-attributes class))) + (push attribute (class-file-attributes class))) (defun class-attribute (class name) (find name (class-file-attributes class) @@ -415,8 +415,8 @@ (setf (class-file-access-flags class) (map-flags (class-file-access-flags class))) - (setf (class-file-class-name class) - (pool-add-class (class-name-internal (class-file-class-name class)))) + (setf (class-file-class class) + (pool-add-class (class-name-internal (class-file-class class)))) ;; (finalize-interfaces) (dolist (field (class-file-fields class)) (finalize-field field class)) @@ -582,7 +582,7 @@ (defun method-add-code (method) "Creates an (empty) 'Code' attribute for the method." (method-add-attribute - (make-code-attribute (+ (length args) + (make-code-attribute (+ (length (cdr (method-descriptor method))) (if (member :static (method-access-flags method)) 0 1))))) ;; 1 == implicit 'this' From ehuelsmann at common-lisp.net Sun Jul 4 08:45:14 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Jul 2010 04:45:14 -0400 Subject: [armedbear-cvs] r12782 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 4 04:45:13 2010 New Revision: 12782 Log: More fixes from test-writing. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Jul 4 04:45:13 2010 @@ -247,7 +247,11 @@ (defun make-constant-long (index value) (%make-constant-double/long 5 index value)) -(defstruct (constant-name/type (:include constant +(defstruct (constant-name/type (:constructor + make-constant-name/type (index + name-index + descriptor-index)) + (:include constant (tag 12))) name-index descriptor-index) @@ -368,16 +372,16 @@ (push entry (pool-entries-list pool))) (constant-index entry))) -(defstruct (class-file (:constructor %make-class-file)) - constants +(defstruct (class-file (:constructor + !make-class-file (class superclass access-flags))) + (constants (make-pool)) access-flags class superclass ;; interfaces fields methods - attributes - ) + attributes) (defun class-add-field (class field) (push field (class-file-fields class))) From ehuelsmann at common-lisp.net Sun Jul 4 09:25:17 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Jul 2010 05:25:17 -0400 Subject: [armedbear-cvs] r12783 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 4 05:25:15 2010 New Revision: 12783 Log: More fixes from test-writing. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Jul 4 05:25:15 2010 @@ -420,7 +420,8 @@ (setf (class-file-access-flags class) (map-flags (class-file-access-flags class))) (setf (class-file-class class) - (pool-add-class (class-name-internal (class-file-class class)))) + (pool-add-class (class-file-constants class) + (class-file-class class))) ;; (finalize-interfaces) (dolist (field (class-file-fields class)) (finalize-field field class)) @@ -516,11 +517,11 @@ (:strict #x0800))) (defun map-flags (flags) - (reduce #'(lambda (x y) + (reduce #'(lambda (y x) (logior (or (when (member (car x) flags) (second x)) - 0) y) - (logior (or ))) + 0) y)) + +access-flags-map+ :initial-value 0)) (defstruct (field (:constructor %make-field)) From ehuelsmann at common-lisp.net Sun Jul 4 09:41:02 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Jul 2010 05:41:02 -0400 Subject: [armedbear-cvs] r12784 - in branches/generic-class-file/abcl: . test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sun Jul 4 05:41:01 2010 New Revision: 12784 Log: Add (some) class file generator tests. Added: branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp (contents, props changed) Modified: branches/generic-class-file/abcl/abcl.asd Modified: branches/generic-class-file/abcl/abcl.asd ============================================================================== --- branches/generic-class-file/abcl/abcl.asd (original) +++ branches/generic-class-file/abcl/abcl.asd Sun Jul 4 05:41:01 2010 @@ -32,6 +32,7 @@ :pathname "test/lisp/abcl/" :components ((:file "compiler-tests") (:file "condition-tests") + (:file "class-file") (:file "metaclass") (:file "mop-tests-setup") (:file "mop-tests" :depends-on ("mop-tests-setup")) Added: branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp ============================================================================== --- (empty file) +++ branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp Sun Jul 4 05:41:01 2010 @@ -0,0 +1,181 @@ +;;; compiler-tests.lisp +;;; +;;; Copyright (C) 2010 Erik Huelsmann +;;; +;;; $Id$ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +#+abcl +(require '#:jvm) + +(in-package #:abcl.test.lisp) + + +(deftest fieldtype.1a + (string= (jvm::internal-field-type :int) "I") + T) + +(deftest fieldtype.1b + (string= (jvm::internal-field-type :long) "J") + T) + +(deftest fieldtype.1c + (string= (jvm::internal-field-type :float) "F") + T) + +(deftest fieldtype.1d + (string= (jvm::internal-field-type :double) "D") + T) + +(deftest fieldtype.1e + (string= (jvm::internal-field-type :boolean) "Z") + T) + +(deftest fieldtype.1f + (string= (jvm::internal-field-type :char) "C") + T) + +(deftest fieldtype.1g + (string= (jvm::internal-field-type :byte) "B") + T) + +(deftest fieldtype.1h + (string= (jvm::internal-field-type :short) "S") + T) + +(deftest fieldtype.1i + (string= (jvm::internal-field-type :void) "V") + T) + +(deftest fieldtype.1j + (string= (jvm::internal-field-type nil) "V") + T) + +(deftest fieldtype.2 + (string= (jvm::internal-field-type jvm::+!lisp-object+) + "org/armedbear/lisp/LispObject") + T) + + +(deftest fieldref.1a + (string= (jvm::internal-field-ref :int) "I") + T) + +(deftest fieldref.1b + (string= (jvm::internal-field-ref :long) "J") + T) + +(deftest fieldref.1c + (string= (jvm::internal-field-ref :float) "F") + T) + +(deftest fieldref.1d + (string= (jvm::internal-field-ref :double) "D") + T) + +(deftest fieldref.1e + (string= (jvm::internal-field-ref :boolean) "Z") + T) + +(deftest fieldref.1f + (string= (jvm::internal-field-ref :char) "C") + T) + +(deftest fieldref.1g + (string= (jvm::internal-field-ref :byte) "B") + T) + +(deftest fieldref.1h + (string= (jvm::internal-field-ref :short) "S") + T) + +(deftest fieldref.1i + (string= (jvm::internal-field-ref :void) "V") + T) + +(deftest fieldref.1j + (string= (jvm::internal-field-ref nil) "V") + T) + +(deftest fieldref.2 + (string= (jvm::internal-field-ref jvm::+!lisp-object+) + "Lorg/armedbear/lisp/LispObject;") + T) + +(deftest descriptor.1 + (and + (string= (jvm::descriptor :void :int :long :boolean) + "(IJZ)V") + (string= (jvm::descriptor nil :int :long :boolean) + "(IJZ)V")) + T) + +(deftest descriptor.2 + (string= (jvm::descriptor jvm::+!lisp-object+ jvm::+!lisp-object+) + "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") + T) + +(deftest map-flags.1 + (eql (jvm::map-flags '(:public)) #x0001)) + +(deftest pool.1 + (let* ((pool (jvm::make-pool))) + (jvm::pool-add-class pool jvm::+!lisp-readtable+) + (jvm::pool-add-field-ref pool jvm::+!lisp-readtable+ "ABC" :int) + (jvm::pool-add-field-ref pool + jvm::+!lisp-readtable+ "ABD" + jvm::+!lisp-readtable+) + (jvm::pool-add-method-ref pool jvm::+!lisp-readtable+ "MBC" :int) + (jvm::pool-add-method-ref pool jvm::+!lisp-readtable+ "MBD" + jvm::+!lisp-readtable+) + (jvm::pool-add-interface-method-ref pool + jvm::+!lisp-readtable+ "MBD" :int) + (jvm::pool-add-interface-method-ref pool + jvm::+!lisp-readtable+ "MBD" + jvm::+!lisp-readtable+) + (jvm::pool-add-string pool "string") + (jvm::pool-add-int pool 1) + (jvm::pool-add-float pool 1.0f0) + (jvm::pool-add-long pool 1) + (jvm::pool-add-double pool 1.0d0) + (jvm::pool-add-name/type pool "name1" :int) + (jvm::pool-add-name/type pool "name2" jvm::+!lisp-object+) + (jvm::pool-add-utf8 pool "utf8") + T) + T) + +(deftest make-class-file.1 + (let* ((class (jvm::make-class-name "org/armedbear/lisp/mcf_1")) + (file (jvm::!make-class-file class jvm::+!lisp-object+ '(:public)))) + (jvm::class-add-field file (jvm::make-field "ABC" :int)) + (jvm::class-add-field file (jvm::make-field "ABD" jvm::+!lisp-object+)) + (jvm::class-add-method file (jvm::!make-method "MBC" nil :int)) + (jvm::class-add-method file (jvm::!make-method "MBD" nil jvm::+!lisp-object+)) + T) + T) + +(deftest finalize-class-file.1 + (let* ((class (jvm::make-class-name "org/armedbear/lisp/mcf_1")) + (file (jvm::!make-class-file class jvm::+!lisp-object+ '(:public)))) + (jvm::class-add-field file (jvm::make-field "ABC" :int)) + (jvm::class-add-field file (jvm::make-field "ABD" jvm::+!lisp-object+)) + (jvm::class-add-method file (jvm::!make-method "MBC" nil '(:int))) + (jvm::class-add-method file + (jvm::!make-method "MBD" nil + (list jvm::+!lisp-object+))) + (jvm::finalize-class-file file) + file) + T) \ No newline at end of file From ehuelsmann at common-lisp.net Sun Jul 4 21:31:19 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Jul 2010 17:31:19 -0400 Subject: [armedbear-cvs] r12785 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jul 4 17:31:17 2010 New Revision: 12785 Log: Documentation. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Jul 4 17:31:17 2010 @@ -58,6 +58,7 @@ (defun map-primitive-type (type) + "Maps a symbolic primitive type name to its Java string representation." (case type (:int "I") (:long "J") @@ -86,12 +87,18 @@ array-ref) (defun make-class-name (name) + "Creates a `class-name' structure for the class or interface `name'. + +`name' should be specified using Java representation, which is converted +to 'internal' (JVM) representation by this function." (setf name (substitute #\/ #\. name)) (%make-class-name :name-internal name :ref (concatenate 'string "L" name ";") :array-ref (concatenate 'string "[L" name ";"))) (defmacro define-class-name (symbol java-dotted-name &optional documentation) + "Convenience macro to define constants for `class-name' structures, +initialized from the `java-dotted-name'." `(defconstant ,symbol (make-class-name ,java-dotted-name) ,documentation)) @@ -153,16 +160,24 @@ |# (defun internal-field-type (field-type) + "Returns a string containing the JVM-internal representation +of `field-type', which should either be a symbol identifying a primitive +type, or a `class-name' structure identifying a class or interface." (if (symbolp field-type) (map-primitive-type field-type) (class-name-internal field-type))) (defun internal-field-ref (field-type) + "Returns a string containing the JVM-internal representation of a reference +to `field-type', which should either be a symbol identifying a primitive +type, or a `class-name' structure identifying a class or interface." (if (symbolp field-type) (map-primitive-type field-type) (class-ref field-type))) (defun descriptor (return-type &rest argument-types) + "Returns a string describing the `return-type' and `argument-types' +in JVM-internal representation." (format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types) (internal-field-type return-type))) @@ -177,7 +192,9 @@ ;; utf8, because both are string values (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0))) + (defstruct constant + "Structure to be included in all constant sub-types." tag index) @@ -209,19 +226,23 @@ (declaim (inline make-constant-field-ref make-constant-method-ref make-constant-interface-method-ref)) (defun make-constant-field-ref (index class-index name/type-index) + "Creates a `constant-member-ref' instance containing a field reference." (%make-constant-member-ref 9 index class-index name/type-index)) (defun make-constant-method-ref (index class-index name/type-index) + "Creates a `constant-member-ref' instance containing a method reference." (%make-constant-member-ref 10 index class-index name/type-index)) (defun make-constant-interface-method-ref (index class-index name/type-index) + "Creates a `constant-member-ref' instance containing an +interface-method reference." (%make-constant-member-ref 11 index class-index name/type-index)) (defstruct (constant-string (:constructor make-constant-string (index value-index)) (:include constant (tag 8))) - value-index) ;;; #### is this the value or the value index??? + value-index) (defstruct (constant-float/int (:constructor %make-constant-float/int (tag index value)) @@ -230,9 +251,11 @@ (declaim (inline make-constant-float make-constant-int)) (defun make-constant-float (index value) + "Creates a `constant-float/int' structure instance containing a float." (%make-constant-float/int 4 index value)) (defun make-constant-int (index value) + "Creates a `constant-float/int' structure instance containing an int." (%make-constant-float/int 3 index value)) (defstruct (constant-double/long (:constructor @@ -242,9 +265,11 @@ (declaim (inline make-constant-double make-constant-float)) (defun make-constant-double (index value) + "Creates a `constant-double/long' structure instance containing a double." (%make-constant-double/long 6 index value)) (defun make-constant-long (index value) + "Creates a `constant-double/long' structure instance containing a long." (%make-constant-double/long 5 index value)) (defstruct (constant-name/type (:constructor @@ -263,7 +288,9 @@ (defun pool-add-class (pool class) - ;; ### do we make class a string or class-name structure? + "Returns the index of the constant-pool class item for `class'. + +`class' must be an instance of `class-name'." (let ((entry (gethash class (pool-entries pool)))) (unless entry (setf entry @@ -275,6 +302,12 @@ (constant-index entry))) (defun pool-add-field-ref (pool class name type) + "Returns the index of the constant-pool item which denotes a reference +to the `name' field of the `class', being of `type'. + +`class' should be an instance of `class-name'. +`name' is a string. +`type' is a field-type (see `internal-field-type')" (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry (setf entry (make-constant-field-ref (incf (pool-count pool)) @@ -285,6 +318,11 @@ (constant-index entry))) (defun pool-add-method-ref (pool class name type) + "Returns the index of the constant-pool item which denotes a reference +to the method with `name' in `class', which is of `type'. + +Here, `type' is a method descriptor, which defines the argument types +and return type. `class' is an instance of `class-name'." (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry (setf entry (make-constant-method-ref (incf (pool-count pool)) @@ -295,6 +333,10 @@ (constant-index entry))) (defun pool-add-interface-method-ref (pool class name type) + "Returns the index of the constant-pool item which denotes a reference to +the method `name' in the interface `class', which is of `type'. + +See `pool-add-method-ref' for remarks." (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry (setf entry @@ -307,6 +349,7 @@ (constant-index entry))) (defun pool-add-string (pool string) + "Returns the index of the constant-pool item denoting the string." (let ((entry (gethash (cons 8 string) ;; 8 == string-tag (pool-entries pool)))) (unless entry @@ -317,6 +360,7 @@ (constant-index entry))) (defun pool-add-int (pool int) + "Returns the index of the constant-pool item denoting the int." (let ((entry (gethash (cons 3 int) (pool-entries pool)))) (unless entry (setf entry (make-constant-int (incf (pool-count pool)) int) @@ -325,6 +369,7 @@ (constant-index entry))) (defun pool-add-float (pool float) + "Returns the index of the constant-pool item denoting the float." (let ((entry (gethash (cons 4 float) (pool-entries pool)))) (unless entry (setf entry (make-constant-float (incf (pool-count pool)) float) @@ -333,6 +378,7 @@ (constant-index entry))) (defun pool-add-long (pool long) + "Returns the index of the constant-pool item denoting the long." (let ((entry (gethash (cons 5 long) (pool-entries pool)))) (unless entry (setf entry (make-constant-long (incf (pool-count pool)) long) @@ -342,6 +388,7 @@ (constant-index entry))) (defun pool-add-double (pool double) + "Returns the index of the constant-pool item denoting the double." (let ((entry (gethash (cons 6 double) (pool-entries pool)))) (unless entry (setf entry (make-constant-double (incf (pool-count pool)) double) @@ -351,6 +398,8 @@ (constant-index entry))) (defun pool-add-name/type (pool name type) + "Returns the index of the constant-pool item denoting +the name/type identifier." (let ((entry (gethash (cons name type) (pool-entries pool))) (internal-type (if (listp type) (apply #'descriptor type) @@ -364,6 +413,8 @@ (constant-index entry))) (defun pool-add-utf8 (pool utf8-as-string) + "Returns the index of the textual value that will be stored in the +class file as UTF-8 encoded data." (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8 (pool-entries pool)))) (unless entry @@ -384,20 +435,27 @@ attributes) (defun class-add-field (class field) + "Adds a `field' created by `make-field'." (push field (class-file-fields class))) (defun class-field (class name) + "Finds a field by name." ;; ### strictly speaking, a field is uniquely + ;; identified by its name and type, not by the name alone. (find name (class-file-fields class) :test #'string= :key #'field-name)) (defun class-add-method (class method) + "Adds a `method' to `class'; the method must have been created using +`make-method'." (push method (class-file-methods class))) (defun class-methods-by-name (class name) + "Returns all methods which have `name'." (remove name (class-file-methods class) :test-not #'string= :key #'method-name)) (defun class-method (class name return &rest args) + "Return the method which is (uniquely) identified by its name AND descriptor." (let ((return-and-args (cons return args))) (find-if #'(lambda (c) (and (string= (method-name c) name) @@ -405,15 +463,21 @@ (class-file-methods class)))) (defun class-add-attribute (class attribute) + "Adds `attribute' to the class; attributes must be instances of +structure classes which include the `attribute' structure class." (push attribute (class-file-attributes class))) (defun class-attribute (class name) + "Returns the attribute which is named `name'." (find name (class-file-attributes class) :test #'string= :key #'attribute-name)) (defun finalize-class-file (class) + "Transforms the representation of the class-file from one +which allows easy modification to one which works best for serialization. +The class can't be modified after serialization." ;; constant pool contains constants finalized on addition; ;; no need for additional finalization @@ -428,14 +492,10 @@ (dolist (method (class-file-methods class)) (finalize-method method class)) ;; top-level attributes (no parent attributes to refer to) - (finalize-attributes (class-file-attributes class) nil class) - -) + (finalize-attributes (class-file-attributes class) nil class)) (defun !write-class-file (class stream) - ;; all components need to finalize themselves: - ;; the constant pool needs to be complete before we start - ;; writing our output. + "Serializes `class' to `stream', after it has been finalized." ;; header (write-u4 #xCAFEBABE stream) @@ -473,23 +533,23 @@ (let ((tag (constant-tag entry))) (write-u1 tag stream) (case tag - (1 ; UTF8 + (1 ; UTF8 (write-utf8 (constant-utf8-value entry) stream)) - ((3 4) ; int + ((3 4) ; int (write-u4 (constant-float/int-value entry) stream)) - ((5 6) ; long double + ((5 6) ; long double (write-u4 (logand (ash (constant-double/long-value entry) -32) #xFFFFffff) stream) (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) stream)) ((9 10 11) ; fieldref methodref InterfaceMethodref (write-u2 (constant-member-ref-class-index entry) stream) (write-u2 (constant-member-ref-name/type-index entry) stream)) - (12 ; nameAndType + (12 ; nameAndType (write-u2 (constant-name/type-name-index entry) stream) (write-u2 (constant-name/type-descriptor-index entry) stream)) - (7 ; class + (7 ; class (write-u2 (constant-class-name-index entry) stream)) - (8 ; string + (8 ; string (write-u2 (constant-string-value-index entry) stream)) (t (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))) @@ -517,6 +577,7 @@ (:strict #x0800))) (defun map-flags (flags) + "Calculates the bitmap of the flags from a list of symbols." (reduce #'(lambda (y x) (logior (or (when (member (car x) flags) (second x)) @@ -528,8 +589,7 @@ access-flags name descriptor - attributes - ) + attributes) (defun make-field (name type &key (flags '(:public))) (%make-field :access-flags flags @@ -564,11 +624,16 @@ access-flags name descriptor - attributes - ) + attributes) (defun map-method-name (name) + "Methods should be identified by strings containing their names, or, +be one of two keyword identifiers to identify special methods: + + * :class-constructor + * :constructor +" (cond ((eq name :class-constructor) "") From ehuelsmann at common-lisp.net Tue Jul 6 21:24:58 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 06 Jul 2010 17:24:58 -0400 Subject: [armedbear-cvs] r12786 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 6 17:24:56 2010 New Revision: 12786 Log: First step of integration of CLASS-NAME structure in pass2. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Jul 6 17:24:56 2010 @@ -200,10 +200,6 @@ (defconstant +fasl-loader-class+ "org/armedbear/lisp/FaslClassLoader") -(defconstant +java-string+ "Ljava/lang/String;") -(defconstant +java-object+ "Ljava/lang/Object;") -(defconstant +lisp-class+ "org/armedbear/lisp/Lisp") -(defconstant +lisp-nil-class+ "org/armedbear/lisp/Nil") (defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass") (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") @@ -261,6 +257,20 @@ (defconstant +lisp-closure-parameter-class+ "org/armedbear/lisp/Closure$Parameter") (defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;") +(defun !class-name (class-name) + "To be eliminated when all hard-coded strings are replaced by `class-name' +structures" + (if (typep class-name 'class-name) + (class-name-internal class-name) + class-name)) + +(defun !class-ref (class-name) + "To be eliminated when all hard-coded strings are +replaced by `class-name' structures" + (if (typep class-name 'class-name) + (class-ref class-name) + class-name)) + (defstruct (instruction (:constructor %make-instruction (opcode args))) (opcode 0 :type (integer 0 255)) args @@ -342,17 +352,17 @@ (defknown emit-push-nil () t) (declaim (inline emit-push-nil)) (defun emit-push-nil () - (emit 'getstatic +lisp-class+ "NIL" +lisp-object+)) + (emit 'getstatic +lisp+ "NIL" +lisp-object+)) (defknown emit-push-nil-symbol () t) (declaim (inline emit-push-nil-symbol)) (defun emit-push-nil-symbol () - (emit 'getstatic +lisp-nil-class+ "NIL" +lisp-symbol+)) + (emit 'getstatic +lisp-nil+ "NIL" +lisp-symbol+)) (defknown emit-push-t () t) (declaim (inline emit-push-t)) (defun emit-push-t () - (emit 'getstatic +lisp-class+ "T" +lisp-symbol+)) + (emit 'getstatic +lisp+ "T" +lisp-symbol+)) (defknown emit-push-false (t) t) (defun emit-push-false (representation) @@ -494,7 +504,9 @@ (declaim (ftype (function (t t) cons) get-descriptor-info)) (defun get-descriptor-info (arg-types return-type) - (let* ((key (list arg-types return-type)) + (let* ((arg-types (mapcar #'!class-ref arg-types)) + (return-type (!class-ref return-type)) + (key (list arg-types return-type)) (ht *descriptors*) (descriptor-info (gethash1 key ht))) (declare (type hash-table ht)) @@ -509,6 +521,7 @@ (let* ((info (get-descriptor-info arg-types return-type)) (descriptor (car info)) (stack-effect (cdr info)) + (class-name (!class-name class-name)) (instruction (emit 'invokestatic class-name method-name descriptor))) (setf (instruction-stack instruction) stack-effect))) @@ -574,7 +587,7 @@ (defknown emit-unbox-boolean () t) (defun emit-unbox-boolean () - (emit 'instanceof +lisp-nil-class+) + (emit 'instanceof +lisp-nil+) (emit 'iconst_1) (emit 'ixor)) ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit @@ -692,6 +705,7 @@ (let* ((info (get-descriptor-info arg-types return-type)) (descriptor (car info)) (stack-effect (cdr info)) + (class-name (!class-name class-name)) (instruction (emit 'invokevirtual class-name method-name descriptor))) (declare (type (signed-byte 8) stack-effect)) (let ((explain *explain*)) @@ -709,6 +723,7 @@ (let* ((info (get-descriptor-info arg-types nil)) (descriptor (car info)) (stack-effect (cdr info)) + (class-name (!class-name class-name)) (instruction (emit 'invokespecial class-name "" descriptor))) (declare (type (signed-byte 8) stack-effect)) (setf (instruction-stack instruction) (1- stack-effect)))) @@ -784,7 +799,7 @@ (emit-load-local-variable variable) (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) - (emit-invokestatic +lisp-class+ "type_error" + (emit-invokestatic +lisp+ "type_error" (lisp-object-arg-types 2) +lisp-object+) (emit 'pop) ; Needed for JVM stack consistency. (label LABEL1)) @@ -842,9 +857,9 @@ (defun maybe-generate-interrupt-check () (unless (> *speed* *safety*) (let ((label1 (gensym))) - (emit 'getstatic +lisp-class+ "interrupted" "Z") + (emit 'getstatic +lisp+ "interrupted" "Z") (emit 'ifeq label1) - (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil) + (emit-invokestatic +lisp+ "handleInterrupt" nil nil) (label label1)))) (defknown single-valued-p (t) t) @@ -1207,7 +1222,8 @@ ;; getstatic, putstatic (define-resolver (178 179) (instruction) (let* ((args (instruction-args instruction)) - (index (pool-field (first args) (second args) (third args)))) + (index (pool-field (!class-name (first args)) + (second args) (third args)))) (inst (instruction-opcode instruction) (u2 index)))) ;; bipush, sipush @@ -1225,7 +1241,8 @@ ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor (define-resolver (182 183 184) (instruction) (let* ((args (instruction-args instruction)) - (index (pool-method (first args) (second args) (third args)))) + (index (pool-method (!class-name (first args)) + (second args) (third args)))) (setf (instruction-args instruction) (u2 index)) instruction)) @@ -1248,13 +1265,14 @@ ;; getfield, putfield class-name field-name type-name (define-resolver (180 181) (instruction) (let* ((args (instruction-args instruction)) - (index (pool-field (first args) (second args) (third args)))) + (index (pool-field (!class-name (first args)) + (second args) (third args)))) (inst (instruction-opcode instruction) (u2 index)))) ;; new, anewarray, checkcast, instanceof class-name (define-resolver (187 189 192 193) (instruction) (let* ((args (instruction-args instruction)) - (index (pool-class (first args)))) + (index (pool-class (!class-name (first args))))) (inst (instruction-opcode instruction) (u2 index)))) ;; iinc @@ -1773,8 +1791,9 @@ (cond ((and lambda-name (symbolp lambda-name) (symbol-package (truly-the symbol lambda-name))) (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name)))) (emit 'ldc (pool-string (package-name (symbol-package (truly-the symbol lambda-name))))) - (emit-invokestatic +lisp-class+ "internInPackage" - (list +java-string+ +java-string+) +lisp-symbol+)) + (emit-invokestatic +lisp+ "internInPackage" + (list +java-string+ +java-string+) + +lisp-symbol+)) (t ;; No name. (emit-push-nil)))) @@ -1785,7 +1804,7 @@ (*print-length* nil) (s (sys::%format nil "~S" lambda-list))) (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+)) (emit-push-nil))) @@ -1855,14 +1874,14 @@ (if (keywordp keyword) (progn (emit 'ldc (pool-string (symbol-name keyword))) - (emit-invokestatic +lisp-class+ "internKeyword" + (emit-invokestatic +lisp+ "internKeyword" (list +java-string+) +lisp-symbol+)) ;; symbol is not really a keyword; yes, that's allowed! (progn (emit 'ldc (pool-string (symbol-name keyword))) (emit 'ldc (pool-string (package-name (symbol-package keyword)))) - (emit-invokestatic +lisp-class+ "internInPackage" + (emit-invokestatic +lisp+ "internInPackage" (list +java-string+ +java-string+) +lisp-symbol+)))) (emit-push-t) ;; we don't need the actual variable-symbol @@ -2093,7 +2112,7 @@ "Generate code to restore a serialized package." (emit 'ldc (pool-string (concatenate 'string "#.(FIND-PACKAGE \"" (package-name pkg) "\")"))) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+)) (defun serialize-object (object) @@ -2102,7 +2121,7 @@ (let ((s (with-output-to-string (stream) (dump-form object stream)))) (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+))) (defun serialize-symbol (symbol) @@ -2120,12 +2139,12 @@ (emit 'checkcast +lisp-symbol-class+)) ((keywordp symbol) (emit 'ldc (pool-string (symbol-name symbol))) - (emit-invokestatic +lisp-class+ "internKeyword" + (emit-invokestatic +lisp+ "internKeyword" (list +java-string+) +lisp-symbol+)) (t (emit 'ldc (pool-string (symbol-name symbol))) (emit 'ldc (pool-string (package-name (symbol-package symbol)))) - (emit-invokestatic +lisp-class+ "internInPackage" + (emit-invokestatic +lisp+ "internInPackage" (list +java-string+ +java-string+) +lisp-symbol+))))) @@ -2189,7 +2208,7 @@ (let ((*code* *static-code*)) (remember field-name object) (emit 'ldc (pool-string field-name)) - (emit-invokestatic +lisp-class+ "recall" + (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) (when (string/= field-type +lisp-object+) (emit 'checkcast (subseq field-type 1 (1- (length field-type))))) @@ -2307,7 +2326,7 @@ ;; previous statements (declare-field g +lisp-object+ +field-access-private+) (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+) (emit 'putstatic *this-class* g +lisp-object+) (if *declare-inline* @@ -2327,9 +2346,9 @@ ;; may depend on something which was declared inline (declare-field g +lisp-object+ +field-access-private+) (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+) - (emit-invokestatic +lisp-class+ "loadTimeValue" + (emit-invokestatic +lisp+ "loadTimeValue" (lisp-object-arg-types 1) +lisp-object+) (emit 'putstatic *this-class* g +lisp-object+) (if *declare-inline* @@ -2352,7 +2371,7 @@ (let* ((*code* *static-code*)) (declare-field g obj-ref +field-access-private+) (emit 'ldc (pool-string g)) - (emit-invokestatic +lisp-class+ "recall" + (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) (when (and obj-class (string/= obj-class +lisp-object-class+)) (emit 'checkcast obj-class)) @@ -2706,7 +2725,7 @@ (arg2 (second args))) (compile-form arg1 'stack nil) (compile-form arg2 'stack nil) - (emit-invokestatic +lisp-class+ "memq" + (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) "Z") (emit-move-from-stack target representation))) (t @@ -2723,10 +2742,10 @@ (compile-form arg1 'stack nil) (compile-form arg2 'stack nil) (cond ((eq type1 'SYMBOL) ; FIXME - (emit-invokestatic +lisp-class+ "memq" + (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) "Z")) (t - (emit-invokestatic +lisp-class+ "memql" + (emit-invokestatic +lisp+ "memql" (lisp-object-arg-types 2) "Z"))) (emit-move-from-stack target representation))) (t @@ -2735,7 +2754,7 @@ (defun p2-gensym (form target representation) (cond ((and (null representation) (null (cdr form))) (emit-push-current-thread) - (emit-invokestatic +lisp-class+ "gensym" + (emit-invokestatic +lisp+ "gensym" (list +lisp-thread+) +lisp-symbol+) (emit-move-from-stack target)) (t @@ -2756,7 +2775,7 @@ (t (compile-form arg3 'stack nil) (maybe-emit-clear-values arg1 arg2 arg3))) - (emit-invokestatic +lisp-class+ "get" + (emit-invokestatic +lisp+ "get" (lisp-object-arg-types (if arg3 3 2)) +lisp-object+) (fix-boxing representation nil) @@ -2778,7 +2797,7 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil arg3 'stack nil) - (emit-invokestatic +lisp-class+ "getf" + (emit-invokestatic +lisp+ "getf" (lisp-object-arg-types 3) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -3084,7 +3103,7 @@ (when *closure-variables* (emit 'checkcast +lisp-compiled-closure-class+) (duplicate-closure-array compiland) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) (process-args args) @@ -3567,7 +3586,7 @@ (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokestatic +lisp-class+ "memq" + (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) "Z") 'ifeq))) @@ -3577,7 +3596,7 @@ (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokestatic +lisp-class+ "memql" + (emit-invokestatic +lisp+ "memql" (lisp-object-arg-types 2) "Z") 'ifeq))) @@ -3817,7 +3836,7 @@ (defun compile-multiple-value-list (form target representation) (emit-clear-values) (compile-form (second form) 'stack nil) - (emit-invokestatic +lisp-class+ "multipleValueList" + (emit-invokestatic +lisp+ "multipleValueList" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target)) @@ -3853,7 +3872,7 @@ (error "Wrong number of arguments for MULTIPLE-VALUE-CALL.")) (2 (compile-form (second form) 'stack nil) - (emit-invokestatic +lisp-class+ "coerceToFunction" + (emit-invokestatic +lisp+ "coerceToFunction" (lisp-object-arg-types 1) +lisp-object+) (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+)) (3 @@ -3863,7 +3882,7 @@ (compile-form (third form) 'stack nil) (aload function-register) (emit-push-current-thread) - (emit-invokestatic +lisp-class+ "multipleValueCall1" + (emit-invokestatic +lisp+ "multipleValueCall1" (list +lisp-object+ +lisp-object+ +lisp-thread+) +lisp-object+))) (t @@ -3872,7 +3891,7 @@ (function-register (allocate-register)) (values-register (allocate-register))) (compile-form (second form) 'stack nil) - (emit-invokestatic +lisp-class+ "coerceToFunction" + (emit-invokestatic +lisp+ "coerceToFunction" (lisp-object-arg-types 1) +lisp-object+) (emit-move-from-stack function-register) (emit 'aconst_null) @@ -4577,7 +4596,7 @@ ;; Non-local GO. (emit-push-variable (tagbody-id-variable tag-block)) (emit-load-externalized-object (tag-label tag)) ; Tag. - (emit-invokestatic +lisp-class+ "nonLocalGo" (lisp-object-arg-types 2) + (emit-invokestatic +lisp+ "nonLocalGo" (lisp-object-arg-types 2) +lisp-object+) ;; Following code will not be reached, but is needed for JVM stack ;; consistency. @@ -4654,7 +4673,7 @@ (define-inlined-function p2-coerce-to-function (form target representation) ((check-arg-count form 1)) (compile-forms-and-maybe-emit-clear-values (%cadr form) 'stack nil) - (emit-invokestatic +lisp-class+ "coerceToFunction" + (emit-invokestatic +lisp+ "coerceToFunction" (lisp-object-arg-types 1) +lisp-object+) (emit-move-from-stack target)) @@ -4747,7 +4766,7 @@ (emit-load-externalized-object (block-name block)) (emit-clear-values) (compile-form result-form 'stack nil) - (emit-invokestatic +lisp-class+ "nonLocalReturn" (lisp-object-arg-types 3) + (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3) +lisp-object+) ;; Following code will not be reached, but is needed for JVM stack ;; consistency. @@ -4824,7 +4843,7 @@ (label label-START) ;; Compile call to Lisp.progvBindVars(). (emit-push-current-thread) - (emit-invokestatic +lisp-class+ "progvBindVars" + (emit-invokestatic +lisp+ "progvBindVars" (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) ;; Implicit PROGN. (let ((*blocks* (cons block *blocks*))) @@ -4938,7 +4957,7 @@ (compiland-closure-register parent)) (emit 'checkcast +lisp-compiled-closure-class+) (duplicate-closure-array parent) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))) (emit-move-to-variable (local-function-variable local-function))) @@ -5031,7 +5050,7 @@ (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) (duplicate-closure-array *current-compiland*) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+)) ; Stack: compiled-closure @@ -5068,7 +5087,7 @@ (when (compiland-closure-register *current-compiland*) (emit 'checkcast +lisp-compiled-closure-class+) (duplicate-closure-array *current-compiland*) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) (emit-move-from-stack target)) @@ -5525,7 +5544,7 @@ (fixnum-type-p type2)) (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack :int) - (emit-invokestatic +lisp-class+ "mod" '("I" "I") "I") + (emit-invokestatic +lisp+ "mod" '("I" "I") "I") (emit-move-from-stack target representation)) ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil @@ -5820,7 +5839,7 @@ (compile-form arg1 'stack :int) (compile-form arg2 'stack nil) (maybe-emit-clear-values arg1 arg2) - (emit-invokestatic +lisp-class+ "writeByte" + (emit-invokestatic +lisp+ "writeByte" (list "I" +lisp-object+) nil) (when target (emit-push-nil) @@ -7480,7 +7499,7 @@ (emit 'instanceof instanceof-class) (emit 'ifne LABEL1) (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) - (emit-invokestatic +lisp-class+ "type_error" + (emit-invokestatic +lisp+ "type_error" (lisp-object-arg-types 2) +lisp-object+) (label LABEL1)) t) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Jul 6 17:24:56 2010 @@ -102,12 +102,12 @@ `(defconstant ,symbol (make-class-name ,java-dotted-name) ,documentation)) -(define-class-name +!java-object+ "java.lang.Object") -(define-class-name +!java-string+ "java.lang.String") +(define-class-name +java-object+ "java.lang.Object") +(define-class-name +java-string+ "java.lang.String") (define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject") (define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString") -(define-class-name +!lisp+ "org.armedbear.lisp.Lisp") -(define-class-name +!lisp-nil+ "org.armedbear.lisp.Nil") +(define-class-name +lisp+ "org.armedbear.lisp.Lisp") +(define-class-name +lisp-nil+ "org.armedbear.lisp.Nil") (define-class-name +!lisp-class+ "org.armedbear.lisp.LispClass") (define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol") (define-class-name +!lisp-thread+ "org.armedbear.lisp.LispThread") From ehuelsmann at common-lisp.net Tue Jul 6 22:34:55 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 06 Jul 2010 18:34:55 -0400 Subject: [armedbear-cvs] r12787 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 6 18:34:54 2010 New Revision: 12787 Log: More CLASS-NAME integration into pass2. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Jul 6 18:34:54 2010 @@ -200,18 +200,15 @@ (defconstant +fasl-loader-class+ "org/armedbear/lisp/FaslClassLoader") -(defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass") (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") -(defconstant +closure-binding-class+ "org/armedbear/lisp/ClosureBinding") (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") (defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject") (defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread") (defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;") -(defconstant +lisp-load-class+ "org/armedbear/lisp/Load") (defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons") (defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;") (defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger") @@ -241,19 +238,12 @@ (defconstant +lisp-environment-class+ "org/armedbear/lisp/Environment") (defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;") (defconstant +lisp-special-binding-class+ "org/armedbear/lisp/SpecialBinding") -(defconstant +lisp-special-bindings-mark+ "Lorg/armedbear/lisp/SpecialBindingsMark;") -(defconstant +lisp-special-bindings-mark-class+ "org/armedbear/lisp/SpecialBindingsMark") (defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw") (defconstant +lisp-return-class+ "org/armedbear/lisp/Return") (defconstant +lisp-go-class+ "org/armedbear/lisp/Go") -(defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure") (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") (defconstant +lisp-hash-table-class+ "org/armedbear/lisp/HashTable") (defconstant +lisp-eql-hash-table-class+ "org/armedbear/lisp/EqlHashTable") -(defconstant +lisp-package-class+ "org/armedbear/lisp/Package") -(defconstant +lisp-readtable-class+ "org/armedbear/lisp/Readtable") -(defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream") -(defconstant +lisp-closure-class+ "org/armedbear/lisp/Closure") (defconstant +lisp-closure-parameter-class+ "org/armedbear/lisp/Closure$Parameter") (defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;") @@ -785,7 +775,7 @@ (CONS +lisp-cons-class+) (HASH-TABLE +lisp-hash-table-class+) (FIXNUM +lisp-fixnum-class+) - (STREAM +lisp-stream-class+) + (STREAM +lisp-stream+) (STRING +lisp-abstract-string-class+) (VECTOR +lisp-abstract-vector-class+))) (expected-type-java-symbol-name (case expected-type @@ -1864,7 +1854,7 @@ (if (null (third param)) ;; supplied-p (emit-push-nil) (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I") + (emit 'getstatic +lisp-closure+ "OPTIONAL" "I") (emit-invokespecial-init +lisp-closure-parameter-class+ (list +lisp-symbol+ +lisp-object+ +lisp-object+ "I"))) @@ -1897,7 +1887,7 @@ (emit-constructor-lambda-name lambda-name) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 2))) - ((equal super +lisp-compiled-closure-class+) + ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME (aload req-params-register) (aload opt-params-register) (aload key-params-register) @@ -2134,7 +2124,7 @@ (emit 'getstatic class name +lisp-symbol+)) ((null (symbol-package symbol)) (emit-push-constant-int (dump-uninterned-symbol-index symbol)) - (emit-invokestatic +lisp-load-class+ "getUninternedSymbol" '("I") + (emit-invokestatic +lisp-load+ "getUninternedSymbol" '("I") +lisp-object+) (emit 'checkcast +lisp-symbol-class+)) ((keywordp symbol) @@ -3052,7 +3042,7 @@ (aload (compiland-closure-register compiland)) ;; src (emit-push-constant-int 0) ;; srcPos (emit-push-constant-int (length *closure-variables*)) - (emit 'anewarray +closure-binding-class+) ;; dest + (emit 'anewarray +lisp-closure-binding+) ;; dest (emit 'dup) (astore register) ;; save dest value (emit-push-constant-int 0) ;; destPos @@ -3101,7 +3091,7 @@ (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* - (emit 'checkcast +lisp-compiled-closure-class+) + (emit 'checkcast +lisp-compiled-closure+) (duplicate-closure-array compiland) (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) @@ -3391,7 +3381,7 @@ (p2-test-predicate form "numberp")) (defun p2-test-packagep (form) - (p2-test-instanceof-predicate form +lisp-package-class+)) + (p2-test-instanceof-predicate form +lisp-package+)) (defun p2-test-rationalp (form) (p2-test-predicate form "rationalp")) @@ -3931,10 +3921,10 @@ (declaim (ftype (function (t) t) emit-new-closure-binding)) (defun emit-new-closure-binding (variable) "" - (emit 'new +closure-binding-class+) ;; value c-b + (emit 'new +lisp-closure-binding+) ;; value c-b (emit 'dup_x1) ;; c-b value c-b (emit 'swap) ;; c-b c-b value - (emit-invokespecial-init +closure-binding-class+ + (emit-invokespecial-init +lisp-closure-binding+ (list +lisp-object+)) ;; c-b (aload (compiland-closure-register *current-compiland*)) ;; c-b array @@ -4235,7 +4225,7 @@ (emit-push-constant-int (variable-closure-index variable)) (emit 'aaload) (emit-swap representation nil) - (emit 'putfield +closure-binding-class+ "value" +lisp-object+)) + (emit 'putfield +lisp-closure-binding+ "value" +lisp-object+)) ((variable-environment variable) (assert (not *file-compilation*)) (emit-load-externalized-object (variable-environment variable) @@ -4267,7 +4257,7 @@ (aload (compiland-closure-register *current-compiland*)) (emit-push-constant-int (variable-closure-index variable)) (emit 'aaload) - (emit 'getfield +closure-binding-class+ "value" +lisp-object+)) + (emit 'getfield +lisp-closure-binding+ "value" +lisp-object+)) ((variable-environment variable) (assert (not *file-compilation*)) (emit-load-externalized-object (variable-environment variable) @@ -4653,10 +4643,10 @@ (p2-instanceof-predicate form target representation +lisp-fixnum-class+)) (defun p2-packagep (form target representation) - (p2-instanceof-predicate form target representation +lisp-package-class+)) + (p2-instanceof-predicate form target representation +lisp-package+)) (defun p2-readtablep (form target representation) - (p2-instanceof-predicate form target representation +lisp-readtable-class+)) + (p2-instanceof-predicate form target representation +lisp-readtable+)) (defun p2-simple-vector-p (form target representation) (p2-instanceof-predicate form target representation +lisp-simple-vector-class+)) @@ -4955,7 +4945,7 @@ (when (compiland-closure-register parent) (dformat t "(compiland-closure-register parent) = ~S~%" (compiland-closure-register parent)) - (emit 'checkcast +lisp-compiled-closure-class+) + (emit 'checkcast +lisp-compiled-closure+) (duplicate-closure-array parent) (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) @@ -5085,7 +5075,7 @@ ; Stack: template-function (when (compiland-closure-register *current-compiland*) - (emit 'checkcast +lisp-compiled-closure-class+) + (emit 'checkcast +lisp-compiled-closure+) (duplicate-closure-array *current-compiland*) (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) @@ -5623,7 +5613,7 @@ ;; errorp is true (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-constant-int 1) ; errorp - (emit-invokestatic +lisp-class-class+ "findClass" + (emit-invokestatic +lisp-class+ "findClass" (list +lisp-object+ "Z") +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -5631,7 +5621,7 @@ (let ((arg2 (second args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :boolean) - (emit-invokestatic +lisp-class-class+ "findClass" + (emit-invokestatic +lisp-class+ "findClass" (list +lisp-object+ "Z") +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -5809,8 +5799,8 @@ (let ((arg (%cadr form))) (cond ((eq (derive-compiler-type arg) 'STREAM) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'checkcast +lisp-stream-class+) - (emit-invokevirtual +lisp-stream-class+ "getElementType" + (emit 'checkcast +lisp-stream+) + (emit-invokevirtual +lisp-stream+ "getElementType" nil +lisp-object+) (emit-move-from-stack target representation)) (t @@ -5828,10 +5818,10 @@ (eq type2 'STREAM)) (compile-form arg1 'stack :int) (compile-form arg2 'stack nil) - (emit 'checkcast +lisp-stream-class+) + (emit 'checkcast +lisp-stream+) (maybe-emit-clear-values arg1 arg2) (emit 'swap) - (emit-invokevirtual +lisp-stream-class+ "_writeByte" '("I") nil) + (emit-invokevirtual +lisp-stream+ "_writeByte" '("I") nil) (when target (emit-push-nil) (emit-move-from-stack target))) @@ -5856,10 +5846,10 @@ (type1 (derive-compiler-type arg1))) (cond ((compiler-subtypep type1 'stream) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) - (emit 'checkcast +lisp-stream-class+) + (emit 'checkcast +lisp-stream+) (emit-push-constant-int 1) (emit-push-nil) - (emit-invokevirtual +lisp-stream-class+ "readLine" + (emit-invokevirtual +lisp-stream+ "readLine" (list "Z" +lisp-object+) +lisp-object+) (emit-move-from-stack target)) (t @@ -5870,10 +5860,10 @@ (arg2 (%cadr args))) (cond ((and (compiler-subtypep type1 'stream) (null arg2)) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) - (emit 'checkcast +lisp-stream-class+) + (emit 'checkcast +lisp-stream+) (emit-push-constant-int 0) (emit-push-nil) - (emit-invokevirtual +lisp-stream-class+ "readLine" + (emit-invokevirtual +lisp-stream+ "readLine" (list "Z" +lisp-object+) +lisp-object+) (emit-move-from-stack target) ) @@ -7487,7 +7477,7 @@ (CONS +lisp-cons-class+) (HASH-TABLE +lisp-hash-table-class+) (FIXNUM +lisp-fixnum-class+) - (STREAM +lisp-stream-class+) + (STREAM +lisp-stream+) (STRING +lisp-abstract-string-class+) (VECTOR +lisp-abstract-vector-class+))) (expected-type-java-symbol-name (case expected-type @@ -7949,8 +7939,9 @@ (defun write-class-file (class-file stream) (let* ((super (abcl-class-file-superclass class-file)) - (this-index (pool-class (abcl-class-file-class class-file))) - (super-index (pool-class super)) + (this (abcl-class-file-class class-file)) + (this-index (pool-class (!class-name this))) + (super-index (pool-class (!class-name super))) (constructor (make-constructor super (abcl-class-file-lambda-name class-file) (abcl-class-file-lambda-list class-file)))) @@ -8102,10 +8093,10 @@ (progn ;; if we're the ultimate parent: create the closure array (emit-push-constant-int (length *closure-variables*)) - (emit 'anewarray +closure-binding-class+)) + (emit 'anewarray +lisp-closure-binding+)) (progn (aload 0) - (emit 'getfield +lisp-compiled-closure-class+ "ctx" + (emit 'getfield +lisp-compiled-closure+ "ctx" +closure-binding-array+) (when local-closure-vars ;; in all other cases, it gets stored in the register below @@ -8129,7 +8120,7 @@ ;; we're the parent, or we have a variable to set. (emit 'dup) ; array (emit-push-constant-int i) - (emit 'new +closure-binding-class+) + (emit 'new +lisp-closure-binding+) (emit 'dup) (cond ((null variable) @@ -8147,7 +8138,7 @@ (setf (variable-index variable) nil)) (t (assert (not "Can't happen!!")))) - (emit-invokespecial-init +closure-binding-class+ + (emit-invokespecial-init +lisp-closure-binding+ (list +lisp-object+)) (emit 'aastore))))) @@ -8247,7 +8238,7 @@ (setf (abcl-class-file-superclass class-file) (if (or *hairy-arglist-p* (and *child-p* *closure-variables*)) - +lisp-compiled-closure-class+ + +lisp-compiled-closure+ +lisp-primitive-class+)) (setf (abcl-class-file-lambda-list class-file) args) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Jul 6 18:34:54 2010 @@ -108,17 +108,17 @@ (define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString") (define-class-name +lisp+ "org.armedbear.lisp.Lisp") (define-class-name +lisp-nil+ "org.armedbear.lisp.Nil") -(define-class-name +!lisp-class+ "org.armedbear.lisp.LispClass") +(define-class-name +lisp-class+ "org.armedbear.lisp.LispClass") (define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol") (define-class-name +!lisp-thread+ "org.armedbear.lisp.LispThread") -(define-class-name +!lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding") +(define-class-name +lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding") (define-class-name +!lisp-integer+ "org.armedbear.lisp.Integer") (define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum") (define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum") (define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat") (define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat") (define-class-name +!lisp-cons+ "org.armedbear.lisp.Cons") -(define-class-name +!lisp-load+ "org.armedbear.lisp.Load") +(define-class-name +lisp-load+ "org.armedbear.lisp.Load") (define-class-name +!lisp-character+ "org.armedbear.lisp.Character") (define-class-name +!lisp-simple-vector+ "org.armedbear.lisp.SimpleVector") (define-class-name +!lisp-abstract-string+ "org.armedbear.lisp.AbstractString") @@ -127,19 +127,18 @@ "org.armedbear.lisp.AbstractBitVector") (define-class-name +!lisp-environment+ "org.armedbear.lisp.Environment") (define-class-name +!lisp-special-binding+ "org.armedbear.lisp.SpecialBinding") -(define-class-name +!lisp-special-binding-mark+ +(define-class-name +lisp-special-binding-mark+ "org.armedbear.lisp.SpecialBindingMark") (define-class-name +!lisp-throw+ "org.armedbear.lisp.Throw") (define-class-name +!lisp-return+ "org.armedbear.lisp.Return") (define-class-name +!lisp-go+ "org.armedbear.lisp.Go") (define-class-name +!lisp-primitive+ "org.armedbear.lisp.Primitive") -(define-class-name +!lisp-compiled-closure+ - "org.armedbear.lisp.CompiledClosure") (define-class-name +!lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable") -(define-class-name +!lisp-package+ "org.armedbear.lisp.Package") -(define-class-name +!lisp-readtable+ "org.armedbear.lisp.Readtable") -(define-class-name +!lisp-stream+ "org.armedbear.lisp.Stream") -(define-class-name +!lisp-closure+ "org.armedbear.lisp.Closure") +(define-class-name +lisp-package+ "org.armedbear.lisp.Package") +(define-class-name +lisp-readtable+ "org.armedbear.lisp.Readtable") +(define-class-name +lisp-stream+ "org.armedbear.lisp.Stream") +(define-class-name +lisp-closure+ "org.armedbear.lisp.Closure") +(define-class-name +lisp-compiled-closure+ "org.armedbear.lisp.CompiledClosure") (define-class-name +!lisp-closure-parameter+ "org.armedbear.lisp.Closure$Parameter") (define-class-name +!fasl-loader+ "org.armedbear.lisp.FaslClassLoader") From ehuelsmann at common-lisp.net Tue Jul 6 22:36:47 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 06 Jul 2010 18:36:47 -0400 Subject: [armedbear-cvs] r12788 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jul 6 18:36:46 2010 New Revision: 12788 Log: Fix typo to restore build. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Jul 6 18:36:46 2010 @@ -127,8 +127,8 @@ "org.armedbear.lisp.AbstractBitVector") (define-class-name +!lisp-environment+ "org.armedbear.lisp.Environment") (define-class-name +!lisp-special-binding+ "org.armedbear.lisp.SpecialBinding") -(define-class-name +lisp-special-binding-mark+ - "org.armedbear.lisp.SpecialBindingMark") +(define-class-name +lisp-special-bindings-mark+ + "org.armedbear.lisp.SpecialBindingsMark") (define-class-name +!lisp-throw+ "org.armedbear.lisp.Throw") (define-class-name +!lisp-return+ "org.armedbear.lisp.Return") (define-class-name +!lisp-go+ "org.armedbear.lisp.Go") From ehuelsmann at common-lisp.net Wed Jul 7 20:53:36 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 07 Jul 2010 16:53:36 -0400 Subject: [armedbear-cvs] r12789 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jul 7 16:53:34 2010 New Revision: 12789 Log: More CLASS-NAME integration. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Jul 7 16:53:34 2010 @@ -198,19 +198,13 @@ (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF)) n))) -(defconstant +fasl-loader-class+ - "org/armedbear/lisp/FaslClassLoader") + (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") -(defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject") -(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread") -(defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;") -(defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons") -(defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;") (defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger") (defconstant +lisp-integer+ "Lorg/armedbear/lisp/LispInteger;") (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum") @@ -234,16 +228,8 @@ (defconstant +lisp-simple-vector-class+ "org/armedbear/lisp/SimpleVector") (defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString") (defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;") -(defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;") -(defconstant +lisp-environment-class+ "org/armedbear/lisp/Environment") (defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;") (defconstant +lisp-special-binding-class+ "org/armedbear/lisp/SpecialBinding") -(defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw") -(defconstant +lisp-return-class+ "org/armedbear/lisp/Return") -(defconstant +lisp-go-class+ "org/armedbear/lisp/Go") -(defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") -(defconstant +lisp-hash-table-class+ "org/armedbear/lisp/HashTable") -(defconstant +lisp-eql-hash-table-class+ "org/armedbear/lisp/EqlHashTable") (defconstant +lisp-closure-parameter-class+ "org/armedbear/lisp/Closure$Parameter") (defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;") @@ -685,7 +671,7 @@ "LispObject") ((equal class +lisp-symbol+) "Symbol") - ((equal class +lisp-thread-class+) + ((equal class +lisp-thread+) "LispThread") (t class))) @@ -725,7 +711,7 @@ (defun maybe-initialize-thread-var () (when *initialize-thread-var* - (emit-invokestatic +lisp-thread-class+ "currentThread" nil +lisp-thread+) + (emit-invokestatic +lisp-thread+ "currentThread" nil +lisp-thread+) (astore *thread*) (setf *initialize-thread-var* nil))) @@ -772,8 +758,8 @@ (let ((instanceof-class (ecase expected-type (SYMBOL +lisp-symbol-class+) (CHARACTER +lisp-character-class+) - (CONS +lisp-cons-class+) - (HASH-TABLE +lisp-hash-table-class+) + (CONS +lisp-cons+) + (HASH-TABLE +lisp-hash-table+) (FIXNUM +lisp-fixnum-class+) (STREAM +lisp-stream+) (STRING +lisp-abstract-string-class+) @@ -1293,7 +1279,7 @@ (list (inst 'aload *thread*) (inst 'aconst_null) - (inst 'putfield (list +lisp-thread-class+ "_values" + (inst 'putfield (list +lisp-thread+ "_values" +lisp-object-array+))))) (dolist (instruction instructions) (vector-push-extend (resolve-instruction instruction) vector)))) @@ -1815,7 +1801,7 @@ (*code* ()) (*handlers* nil)) (setf (method-max-locals constructor) 1) - (unless (equal super +lisp-primitive-class+) + (unless (eq super +lisp-primitive+) (multiple-value-bind (req opt key key-p rest allow-other-keys-p) @@ -1883,7 +1869,7 @@ (list +lisp-symbol+ +lisp-symbol+ +lisp-object+ +lisp-object+)))))) (aload 0) ;; this - (cond ((equal super +lisp-primitive-class+) + (cond ((eq super +lisp-primitive+) (emit-constructor-lambda-name lambda-name) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 2))) @@ -2156,7 +2142,7 @@ 4. The function to dispatch serialization to 5. The type of the field to save the serialized result to") -(defknown emit-load-externalized-object (t) string) +(defknown emit-load-externalized-object (t &optional t) string) (defun emit-load-externalized-object (object &optional cast) "Externalizes `object' for use in a FASL. @@ -2802,10 +2788,10 @@ (let ((key-form (%cadr form)) (ht-form (%caddr form))) (compile-form ht-form 'stack nil) - (emit 'checkcast +lisp-hash-table-class+) + (emit 'checkcast +lisp-hash-table+) (compile-form key-form 'stack nil) (maybe-emit-clear-values ht-form key-form) - (emit-invokevirtual +lisp-hash-table-class+ "gethash1" + (emit-invokevirtual +lisp-hash-table+ "gethash1" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -2820,17 +2806,17 @@ (ht-form (%caddr form)) (value-form (fourth form))) (compile-form ht-form 'stack nil) - (emit 'checkcast +lisp-hash-table-class+) + (emit 'checkcast +lisp-hash-table+) (compile-form key-form 'stack nil) (compile-form value-form 'stack nil) (maybe-emit-clear-values ht-form key-form value-form) (cond (target - (emit-invokevirtual +lisp-hash-table-class+ "puthash" + (emit-invokevirtual +lisp-hash-table+ "puthash" (lisp-object-arg-types 2) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t - (emit-invokevirtual +lisp-hash-table-class+ "put" + (emit-invokevirtual +lisp-hash-table+ "put" (lisp-object-arg-types 2) nil))))) (t (compile-function-call form target representation)))) @@ -2908,7 +2894,7 @@ (lisp-object-arg-types (1+ numargs)) (list +lisp-object+ +lisp-object-array+))) (return-type +lisp-object+)) - (emit-invokevirtual +lisp-thread-class+ "execute" arg-types return-type))) + (emit-invokevirtual +lisp-thread+ "execute" arg-types return-type))) (defknown compile-function-call (t t t) t) (defun compile-function-call (form target representation) @@ -3077,9 +3063,9 @@ (assert (not *file-compilation*)) (emit-load-externalized-object (local-function-environment local-function) - +lisp-environment-class+) + +lisp-environment+) (emit-load-externalized-object (local-function-name local-function)) - (emit-invokevirtual +lisp-environment-class+ "lookupFunction" + (emit-invokevirtual +lisp-environment+ "lookupFunction" (list +lisp-object+) +lisp-object+)) (t @@ -3399,10 +3385,10 @@ (p2-test-instanceof-predicate form +lisp-symbol-class+)) (defun p2-test-consp (form) - (p2-test-instanceof-predicate form +lisp-cons-class+)) + (p2-test-instanceof-predicate form +lisp-cons+)) (defun p2-test-atom (form) - (p2-test-instanceof-predicate form +lisp-cons-class+) + (p2-test-instanceof-predicate form +lisp-cons+) 'ifne) (defun p2-test-fixnump (form) @@ -3841,14 +3827,14 @@ (compile-form first-subform result-register nil) ;; Save multiple values returned by first subform. (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register) (dolist (subform subforms) (compile-form subform nil nil)) ;; Restore multiple values returned by first subform. (emit-push-current-thread) (aload values-register) - (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit 'putfield +lisp-thread+ "_values" +lisp-object-array+) ;; Result. (aload result-register) (fix-boxing representation nil) @@ -3891,7 +3877,7 @@ (emit-push-current-thread) (emit 'swap) (aload values-register) - (emit-invokevirtual +lisp-thread-class+ "accumulateValues" + (emit-invokevirtual +lisp-thread+ "accumulateValues" (list +lisp-object+ +lisp-object-array+) +lisp-object-array+) (astore values-register) @@ -3944,7 +3930,7 @@ (emit 'swap) (emit-push-variable-name variable) (emit 'swap) - (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (emit-invokevirtual +lisp-thread+ "bindSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-special-binding+) (if (variable-binding-register variable) @@ -3985,13 +3971,13 @@ (defun restore-dynamic-environment (register) (emit-push-current-thread) (aload register) - (emit-invokevirtual +lisp-thread-class+ "resetSpecialBindings" + (emit-invokevirtual +lisp-thread+ "resetSpecialBindings" (list +lisp-special-bindings-mark+) nil) ) (defun save-dynamic-environment (register) (emit-push-current-thread) - (emit-invokevirtual +lisp-thread-class+ "markSpecialBindings" + (emit-invokevirtual +lisp-thread+ "markSpecialBindings" nil +lisp-special-bindings-mark+) (astore register) ) @@ -4050,7 +4036,7 @@ (compile-form (third form) result-register nil) ;; Store values from values form in values register. (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+) (emit-move-from-stack values-register) ;; Did we get just one value? (aload values-register) @@ -4069,7 +4055,7 @@ (emit-push-current-thread) (aload result-register) (emit-push-constant-int (length vars)) - (emit-invokevirtual +lisp-thread-class+ "getValues" + (emit-invokevirtual +lisp-thread+ "getValues" (list +lisp-object+ "I") +lisp-object-array+) ;; Values array is now on the stack at runtime. (label LABEL2) @@ -4229,11 +4215,11 @@ ((variable-environment variable) (assert (not *file-compilation*)) (emit-load-externalized-object (variable-environment variable) - +lisp-environment-class+) + +lisp-environment+) (emit 'swap) (emit-push-variable-name variable) (emit 'swap) - (emit-invokevirtual +lisp-environment-class+ "rebind" + (emit-invokevirtual +lisp-environment+ "rebind" (list +lisp-symbol+ +lisp-object+) nil)) (t @@ -4261,9 +4247,9 @@ ((variable-environment variable) (assert (not *file-compilation*)) (emit-load-externalized-object (variable-environment variable) - +lisp-environment-class+) + +lisp-environment+) (emit-push-variable-name variable) - (emit-invokevirtual +lisp-environment-class+ "lookup" + (emit-invokevirtual +lisp-environment+ "lookup" (list +lisp-object+) +lisp-object+)) (t @@ -4356,7 +4342,7 @@ ;; The special case of binding a special to its current value. (emit-push-current-thread) (emit-push-variable-name variable) - (emit-invokevirtual +lisp-thread-class+ + (emit-invokevirtual +lisp-thread+ "bindSpecialToCurrentValue" (list +lisp-symbol+) +lisp-special-binding+) @@ -4516,11 +4502,11 @@ (emit 'dup) (astore go-register) ;; Get the tag. - (emit 'getfield +lisp-go-class+ "tagbody" +lisp-object+) ; Stack depth is still 1. + (emit 'getfield +lisp-go+ "tagbody" +lisp-object+) ; Stack depth is still 1. (emit-push-variable (tagbody-id-variable block)) (emit 'if_acmpne RETHROW) ;; Not this TAGBODY (aload go-register) - (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1. + (emit 'getfield +lisp-go+ "tag" +lisp-object+) ; Stack depth is still 1. (astore tag-register) ;; Don't actually generate comparisons for tags ;; to which there is no non-local GO instruction @@ -4544,7 +4530,7 @@ (push (make-handler :from BEGIN-BLOCK :to END-BLOCK :code HANDLER - :catch-type (pool-class +lisp-go-class+)) + :catch-type (pool-class (!class-name +lisp-go+))) *handlers*) (push (make-handler :from BEGIN-BLOCK :to END-BLOCK @@ -4597,7 +4583,7 @@ ((aver (or (null representation) (eq representation :boolean))) (check-arg-count form 1)) (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil) - (emit 'instanceof +lisp-cons-class+) + (emit 'instanceof +lisp-cons+) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) (emit 'ifeq LABEL1) @@ -4637,7 +4623,7 @@ (p2-instanceof-predicate form target representation +lisp-character-class+)) (defun p2-consp (form target representation) - (p2-instanceof-predicate form target representation +lisp-cons-class+)) + (p2-instanceof-predicate form target representation +lisp-cons+)) (defun p2-fixnump (form target representation) (p2-instanceof-predicate form target representation +lisp-fixnum-class+)) @@ -4699,7 +4685,7 @@ (label HANDLER) ;; The Return object is on the runtime stack. Stack depth is 1. (emit 'dup) ; Stack depth is 2. - (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2. + (emit 'getfield +lisp-return+ "tag" +lisp-object+) ; Still 2. (emit-push-variable (block-id-variable block)) ;; If it's not the block we're looking for... (emit 'if_acmpeq THIS-BLOCK) ; Stack depth is 1. @@ -4709,13 +4695,13 @@ (emit-move-to-variable (block-id-variable block)) (emit 'athrow) (label THIS-BLOCK) - (emit 'getfield +lisp-return-class+ "result" +lisp-object+) + (emit 'getfield +lisp-return+ "result" +lisp-object+) (emit-move-from-stack target) ; Stack depth is 0. ;; Finally... (push (make-handler :from BEGIN-BLOCK :to END-BLOCK :code HANDLER - :catch-type (pool-class +lisp-return-class+)) + :catch-type (pool-class (!class-name +lisp-return+))) *handlers*) (push (make-handler :from BEGIN-BLOCK :to END-BLOCK @@ -4784,14 +4770,14 @@ (define-inlined-function p2-cons (form target representation) ((check-arg-count form 2)) - (emit 'new +lisp-cons-class+) + (emit 'new +lisp-cons+) (emit 'dup) (let* ((args (%cdr form)) (arg1 (%car args)) (arg2 (%cadr args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil)) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)) (emit-move-from-stack target)) (defun compile-progn (form target representation) @@ -5749,7 +5735,7 @@ (defun p2-%make-structure (form target representation) (cond ((and (check-arg-count form 2) (eq (derive-type (%cadr form)) 'SYMBOL)) - (emit 'new +lisp-structure-object-class+) + (emit 'new +lisp-structure-object+) (emit 'dup) (compile-form (%cadr form) 'stack nil) (emit 'checkcast +lisp-symbol-class+) @@ -5757,7 +5743,7 @@ (maybe-emit-clear-values (%cadr form) (%caddr form)) (emit-invokevirtual +lisp-object-class+ "copyToArray" nil +lisp-object-array+) - (emit-invokespecial-init +lisp-structure-object-class+ + (emit-invokespecial-init +lisp-structure-object+ (list +lisp-symbol+ +lisp-object-array+)) (emit-move-from-stack target representation)) (t @@ -5769,14 +5755,14 @@ (slot-count (length slot-forms))) (cond ((and (<= 1 slot-count 6) (eq (derive-type (%car args)) 'SYMBOL)) - (emit 'new +lisp-structure-object-class+) + (emit 'new +lisp-structure-object+) (emit 'dup) (compile-form (%car args) 'stack nil) (emit 'checkcast +lisp-symbol-class+) (dolist (slot-form slot-forms) (compile-form slot-form 'stack nil)) (apply 'maybe-emit-clear-values args) - (emit-invokespecial-init +lisp-structure-object-class+ + (emit-invokespecial-init +lisp-structure-object+ (append (list +lisp-symbol+) (make-list slot-count :initial-element +lisp-object+))) (emit-move-from-stack target representation)) @@ -5785,9 +5771,9 @@ (defun p2-make-hash-table (form target representation) (cond ((= (length form) 1) ; no args - (emit 'new +lisp-eql-hash-table-class+) + (emit 'new +lisp-eql-hash-table+) (emit 'dup) - (emit-invokespecial-init +lisp-eql-hash-table-class+ nil) + (emit-invokespecial-init +lisp-eql-hash-table+ nil) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t @@ -6451,19 +6437,19 @@ args))) (cond ((>= 4 length 1) (dolist (cons-head cons-heads) - (emit 'new +lisp-cons-class+) + (emit 'new +lisp-cons+) (emit 'dup) (compile-form cons-head 'stack nil)) (if list-star-p (compile-form (first (last args)) 'stack nil) (progn (emit-invokespecial-init - +lisp-cons-class+ (lisp-object-arg-types 1)) + +lisp-cons+ (lisp-object-arg-types 1)) (pop cons-heads))) ; we've handled one of the args, so remove it (dolist (cons-head cons-heads) (declare (ignore cons-head)) (emit-invokespecial-init - +lisp-cons-class+ (lisp-object-arg-types 2))) + +lisp-cons+ (lisp-object-arg-types 2))) (if list-star-p (progn (apply #'maybe-emit-clear-values args) @@ -7180,7 +7166,7 @@ (case len (0 (emit-push-current-thread) - (emit-invokevirtual +lisp-thread-class+ "setValues" nil +lisp-object+) + (emit-invokevirtual +lisp-thread+ "setValues" nil +lisp-object+) (emit-move-from-stack target)) (1 (let ((arg (%car args))) @@ -7200,7 +7186,7 @@ (t (compile-form arg1 'stack nil) (compile-form arg2 'stack nil)))) - (emit-invokevirtual +lisp-thread-class+ + (emit-invokevirtual +lisp-thread+ "setValues" (lisp-object-arg-types len) +lisp-object+) @@ -7210,7 +7196,7 @@ (emit-push-current-thread) (dolist (arg args) (compile-form arg 'stack nil)) - (emit-invokevirtual +lisp-thread-class+ + (emit-invokevirtual +lisp-thread+ "setValues" (lisp-object-arg-types len) +lisp-object+) @@ -7282,7 +7268,7 @@ (emit 'checkcast +lisp-symbol-class+) (compile-form (%caddr form) 'stack nil) (maybe-emit-clear-values (%cadr form) (%caddr form)) - (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" + (emit-invokevirtual +lisp-thread+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -7334,13 +7320,13 @@ (emit-push-current-thread) (emit-load-externalized-object name) (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) - (emit-invokevirtual +lisp-thread-class+ "pushSpecial" + (emit-invokevirtual +lisp-thread+ "pushSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-object+)) (t (emit-push-current-thread) (emit-load-externalized-object name) (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) - (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" + (emit-invokevirtual +lisp-thread+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+))) (fix-boxing representation nil) (emit-move-from-stack target representation) @@ -7474,8 +7460,8 @@ (let ((instanceof-class (ecase expected-type (SYMBOL +lisp-symbol-class+) (CHARACTER +lisp-character-class+) - (CONS +lisp-cons-class+) - (HASH-TABLE +lisp-hash-table-class+) + (CONS +lisp-cons+) + (HASH-TABLE +lisp-hash-table+) (FIXNUM +lisp-fixnum-class+) (STREAM +lisp-stream+) (STRING +lisp-abstract-string-class+) @@ -7681,7 +7667,7 @@ (compile-form (second form) tag-register nil) ; Tag. (emit-push-current-thread) (aload tag-register) - (emit-invokevirtual +lisp-thread-class+ "pushCatchTag" + (emit-invokevirtual +lisp-thread+ "pushCatchTag" (lisp-object-arg-types 1) nil) (let ((*blocks* (cons block *blocks*))) ; Stack depth is 0. @@ -7692,29 +7678,29 @@ (label THROW-HANDLER) ; Start of handler for THROW. ;; The Throw object is on the runtime stack. Stack depth is 1. (emit 'dup) ; Stack depth is 2. - (emit 'getfield +lisp-throw-class+ "tag" +lisp-object+) ; Still 2. + (emit 'getfield +lisp-throw+ "tag" +lisp-object+) ; Still 2. (aload tag-register) ; Stack depth is 3. ;; If it's not the tag we're looking for, we branch to the start of the ;; catch-all handler, which will do a re-throw. (emit 'if_acmpne DEFAULT-HANDLER) ; Stack depth is 1. (emit-push-current-thread) - (emit-invokevirtual +lisp-throw-class+ "getResult" + (emit-invokevirtual +lisp-throw+ "getResult" (list +lisp-thread+) +lisp-object+) (emit-move-from-stack target) ; Stack depth is 0. (emit 'goto EXIT) (label DEFAULT-HANDLER) ; Start of handler for all other Throwables. ;; A Throwable object is on the runtime stack here. Stack depth is 1. (emit-push-current-thread) - (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) + (emit-invokevirtual +lisp-thread+ "popCatchTag" nil nil) (emit 'athrow) ; Re-throw. (label EXIT) ;; Finally... (emit-push-current-thread) - (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) + (emit-invokevirtual +lisp-thread+ "popCatchTag" nil nil) (let ((handler1 (make-handler :from BEGIN-PROTECTED-RANGE :to END-PROTECTED-RANGE :code THROW-HANDLER - :catch-type (pool-class +lisp-throw-class+))) + :catch-type (pool-class (!class-name +lisp-throw+)))) (handler2 (make-handler :from BEGIN-PROTECTED-RANGE :to END-PROTECTED-RANGE :code DEFAULT-HANDLER @@ -7730,7 +7716,7 @@ (compile-form (second form) 'stack nil) ; Tag. (emit-clear-values) ; Do this unconditionally! (MISC.503) (compile-form (third form) 'stack nil) ; Result. - (emit-invokevirtual +lisp-thread-class+ "throwToTag" + (emit-invokevirtual +lisp-thread+ "throwToTag" (lisp-object-arg-types 2) nil) ;; Following code will not be reached. (when target @@ -7773,7 +7759,7 @@ (compile-form protected-form result-register nil) (unless (single-valued-p protected-form) (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register)) (label END-PROTECTED-RANGE)) (let ((*register* *register*)) @@ -7786,7 +7772,7 @@ ;; The Throwable object is on the runtime stack. Stack depth is 1. (astore exception-register) (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register) (let ((*register* *register*)) (dolist (subform cleanup-forms) @@ -7794,7 +7780,7 @@ (maybe-emit-clear-values cleanup-forms) (emit-push-current-thread) (aload values-register) - (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit 'putfield +lisp-thread+ "_values" +lisp-object-array+) (aload exception-register) (emit 'athrow) ; Re-throw exception. (label EXIT) @@ -7802,7 +7788,7 @@ (unless (single-valued-p protected-form) (emit-push-current-thread) (aload values-register) - (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+)) + (emit 'putfield +lisp-thread+ "_values" +lisp-object-array+)) ;; Result. (aload result-register) (emit-move-from-stack target) @@ -8190,7 +8176,7 @@ (emit-push-constant-int (variable-index variable)) (emit 'aaload) (setf (variable-index variable) nil))) - (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (emit-invokevirtual +lisp-thread+ "bindSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-special-binding+) (astore (variable-binding-register variable))))) @@ -8239,7 +8225,7 @@ (if (or *hairy-arglist-p* (and *child-p* *closure-variables*)) +lisp-compiled-closure+ - +lisp-primitive-class+)) + +lisp-primitive+)) (setf (abcl-class-file-lambda-list class-file) args) (setf (method-max-locals execute-method) *registers-allocated*) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Wed Jul 7 16:53:34 2010 @@ -110,30 +110,32 @@ (define-class-name +lisp-nil+ "org.armedbear.lisp.Nil") (define-class-name +lisp-class+ "org.armedbear.lisp.LispClass") (define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol") -(define-class-name +!lisp-thread+ "org.armedbear.lisp.LispThread") +(define-class-name +lisp-thread+ "org.armedbear.lisp.LispThread") (define-class-name +lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding") (define-class-name +!lisp-integer+ "org.armedbear.lisp.Integer") (define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum") (define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum") (define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat") (define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat") -(define-class-name +!lisp-cons+ "org.armedbear.lisp.Cons") +(define-class-name +lisp-cons+ "org.armedbear.lisp.Cons") (define-class-name +lisp-load+ "org.armedbear.lisp.Load") (define-class-name +!lisp-character+ "org.armedbear.lisp.Character") +(define-class-name +lisp-structure-object+ "org.armedbear.lisp.StructureObject") (define-class-name +!lisp-simple-vector+ "org.armedbear.lisp.SimpleVector") (define-class-name +!lisp-abstract-string+ "org.armedbear.lisp.AbstractString") (define-class-name +!lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector") (define-class-name +!lisp-abstract-bit-vector+ "org.armedbear.lisp.AbstractBitVector") -(define-class-name +!lisp-environment+ "org.armedbear.lisp.Environment") +(define-class-name +lisp-environment+ "org.armedbear.lisp.Environment") (define-class-name +!lisp-special-binding+ "org.armedbear.lisp.SpecialBinding") (define-class-name +lisp-special-bindings-mark+ "org.armedbear.lisp.SpecialBindingsMark") -(define-class-name +!lisp-throw+ "org.armedbear.lisp.Throw") -(define-class-name +!lisp-return+ "org.armedbear.lisp.Return") -(define-class-name +!lisp-go+ "org.armedbear.lisp.Go") -(define-class-name +!lisp-primitive+ "org.armedbear.lisp.Primitive") -(define-class-name +!lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable") +(define-class-name +lisp-throw+ "org.armedbear.lisp.Throw") +(define-class-name +lisp-return+ "org.armedbear.lisp.Return") +(define-class-name +lisp-go+ "org.armedbear.lisp.Go") +(define-class-name +lisp-primitive+ "org.armedbear.lisp.Primitive") +(define-class-name +lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable") +(define-class-name +lisp-hash-table+ "org.armedbear.lisp.HashTable") (define-class-name +lisp-package+ "org.armedbear.lisp.Package") (define-class-name +lisp-readtable+ "org.armedbear.lisp.Readtable") (define-class-name +lisp-stream+ "org.armedbear.lisp.Stream") From ehuelsmann at common-lisp.net Wed Jul 7 22:15:15 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 07 Jul 2010 18:15:15 -0400 Subject: [armedbear-cvs] r12790 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jul 7 18:15:14 2010 New Revision: 12790 Log: More CLASS-NAME integration. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Jul 7 18:15:14 2010 @@ -210,8 +210,8 @@ (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum") (defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;") (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;") -(defconstant +lisp-function-proxy-class+ - "org/armedbear/lisp/AutoloadedFunctionProxy") +;(defconstant +lisp-function-proxy-class+ +; "org/armedbear/lisp/AutoloadedFunctionProxy") (defconstant +lisp-bignum-class+ "org/armedbear/lisp/Bignum") (defconstant +lisp-bignum+ "Lorg/armedbear/lisp/Bignum;") (defconstant +lisp-single-float-class+ "org/armedbear/lisp/SingleFloat") @@ -221,16 +221,6 @@ (defconstant +lisp-character-class+ "org/armedbear/lisp/LispCharacter") (defconstant +lisp-character+ "Lorg/armedbear/lisp/LispCharacter;") (defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;") -(defconstant +lisp-abstract-bit-vector-class+ "org/armedbear/lisp/AbstractBitVector") -(defconstant +lisp-abstract-vector-class+ "org/armedbear/lisp/AbstractVector") -(defconstant +lisp-abstract-string-class+ "org/armedbear/lisp/AbstractString") -(defconstant +lisp-abstract-string+ "Lorg/armedbear/lisp/AbstractString;") -(defconstant +lisp-simple-vector-class+ "org/armedbear/lisp/SimpleVector") -(defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString") -(defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;") -(defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;") -(defconstant +lisp-special-binding-class+ "org/armedbear/lisp/SpecialBinding") -(defconstant +lisp-closure-parameter-class+ "org/armedbear/lisp/Closure$Parameter") (defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;") (defun !class-name (class-name) @@ -762,8 +752,8 @@ (HASH-TABLE +lisp-hash-table+) (FIXNUM +lisp-fixnum-class+) (STREAM +lisp-stream+) - (STRING +lisp-abstract-string-class+) - (VECTOR +lisp-abstract-vector-class+))) + (STRING +lisp-abstract-string+) + (VECTOR +lisp-abstract-vector+))) (expected-type-java-symbol-name (case expected-type (HASH-TABLE "HASH_TABLE") (t @@ -1199,7 +1189,7 @@ (define-resolver (178 179) (instruction) (let* ((args (instruction-args instruction)) (index (pool-field (!class-name (first args)) - (second args) (third args)))) + (second args) (!class-ref (third args))))) (inst (instruction-opcode instruction) (u2 index)))) ;; bipush, sipush @@ -1242,7 +1232,7 @@ (define-resolver (180 181) (instruction) (let* ((args (instruction-args instruction)) (index (pool-field (!class-name (first args)) - (second args) (third args)))) + (second args) (!class-ref (third args))))) (inst (instruction-opcode instruction) (u2 index)))) ;; new, anewarray, checkcast, instanceof class-name @@ -1814,7 +1804,7 @@ (let ((count-sym (gensym))) `(progn (emit-push-constant-int (length ,params)) - (emit 'anewarray +lisp-closure-parameter-class+) + (emit 'anewarray +lisp-closure-parameter+) (astore (setf ,register (method-max-locals constructor))) (incf (method-max-locals constructor)) (do* ((,count-sym 0 (1+ ,count-sym)) @@ -1824,14 +1814,14 @@ (declare (ignorable ,param)) (aload ,register) (emit-push-constant-int ,count-sym) - (emit 'new +lisp-closure-parameter-class+) + (emit 'new +lisp-closure-parameter+) (emit 'dup) , at body (emit 'aastore)))))) ;; process required args (parameters-to-array (ignore req req-params-register) (emit-push-t) ;; we don't need the actual symbol - (emit-invokespecial-init +lisp-closure-parameter-class+ + (emit-invokespecial-init +lisp-closure-parameter+ (list +lisp-symbol+))) (parameters-to-array (param opt opt-params-register) @@ -1841,7 +1831,7 @@ (emit-push-nil) (emit-push-t)) ;; we don't need the actual supplied-p symbol (emit 'getstatic +lisp-closure+ "OPTIONAL" "I") - (emit-invokespecial-init +lisp-closure-parameter-class+ + (emit-invokespecial-init +lisp-closure-parameter+ (list +lisp-symbol+ +lisp-object+ +lisp-object+ "I"))) @@ -1865,7 +1855,7 @@ (if (null (third param)) (emit-push-nil) (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit-invokespecial-init +lisp-closure-parameter-class+ + (emit-invokespecial-init +lisp-closure-parameter+ (list +lisp-symbol+ +lisp-symbol+ +lisp-object+ +lisp-object+)))))) (aload 0) ;; this @@ -1985,7 +1975,7 @@ (defknown declare-field (t t t) t) (defun declare-field (name descriptor access-flags) - (let ((field (make-field name descriptor))) + (let ((field (make-field name (!class-ref descriptor)))) ;; final static (setf (field-access-flags field) (logior +field-flag-final+ +field-flag-static+ access-flags)) @@ -2079,10 +2069,10 @@ (defun serialize-string (string) "Generate code to restore a serialized string." - (emit 'new +lisp-simple-string-class+) + (emit 'new +lisp-simple-string+) (emit 'dup) (emit 'ldc (pool-string string)) - (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))) + (emit-invokespecial-init +lisp-simple-string+ (list +java-string+))) (defun serialize-package (pkg) "Generate code to restore a serialized package." @@ -2125,15 +2115,15 @@ +lisp-symbol+))))) (defvar serialization-table - `((integer "INT" ,#'eql ,#'serialize-integer ,+lisp-integer+) - (character "CHR" ,#'eql ,#'serialize-character ,+lisp-character+) - (single-float "FLT" ,#'eql ,#'serialize-float ,+lisp-single-float+) - (double-float "DBL" ,#'eql ,#'serialize-double ,+lisp-double-float+) + `((integer "INT" ,#'eql ,#'serialize-integer ,+!lisp-integer+) + (character "CHR" ,#'eql ,#'serialize-character ,+!lisp-character+) + (single-float "FLT" ,#'eql ,#'serialize-float ,+!lisp-single-float+) + (double-float "DBL" ,#'eql ,#'serialize-double ,+!lisp-double-float+) (string "STR" ,#'equal ,#'serialize-string ,+lisp-abstract-string+) ;; because of (not compile-file) - (package "PKG" ,#'eq ,#'serialize-package ,+lisp-object+) - (symbol "SYM" ,#'eq ,#'serialize-symbol ,+lisp-symbol+) - (T "OBJ" ,#'eq ,#'serialize-object ,+lisp-object+)) + (package "PKG" ,#'eq ,#'serialize-package ,+!lisp-object+) + (symbol "SYM" ,#'eq ,#'serialize-symbol ,+!lisp-symbol+) + (T "OBJ" ,#'eq ,#'serialize-object ,+!lisp-object+)) "A list of 5-element lists. The elements of the sublists mean: 1. The type of the value to be serialized @@ -2186,8 +2176,8 @@ (emit 'ldc (pool-string field-name)) (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) - (when (string/= field-type +lisp-object+) - (emit 'checkcast (subseq field-type 1 (1- (length field-type))))) + (when (not (eq field-type +!lisp-object+)) + (emit 'checkcast field-type)) (emit 'putstatic *this-class* field-name field-type) (setf *static-code* *code*))) (*declare-inline* @@ -3296,7 +3286,7 @@ 'ifeq))) (defun p2-test-bit-vector-p (form) - (p2-test-instanceof-predicate form +lisp-abstract-bit-vector-class+)) + (p2-test-instanceof-predicate form +lisp-abstract-bit-vector+)) (defun p2-test-characterp (form) (p2-test-instanceof-predicate form +lisp-character-class+)) @@ -3395,13 +3385,13 @@ (p2-test-instanceof-predicate form +lisp-fixnum-class+)) (defun p2-test-stringp (form) - (p2-test-instanceof-predicate form +lisp-abstract-string-class+)) + (p2-test-instanceof-predicate form +lisp-abstract-string+)) (defun p2-test-vectorp (form) - (p2-test-instanceof-predicate form +lisp-abstract-vector-class+)) + (p2-test-instanceof-predicate form +lisp-abstract-vector+)) (defun p2-test-simple-vector-p (form) - (p2-test-instanceof-predicate form +lisp-simple-vector-class+)) + (p2-test-instanceof-predicate form +lisp-simple-vector+)) (defknown compile-test-form (t) t) (defun compile-test-form (test-form) @@ -4617,7 +4607,7 @@ (emit-move-from-stack target representation))))) (defun p2-bit-vector-p (form target representation) - (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector-class+)) + (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector+)) (defun p2-characterp (form target representation) (p2-instanceof-predicate form target representation +lisp-character-class+)) @@ -4635,16 +4625,16 @@ (p2-instanceof-predicate form target representation +lisp-readtable+)) (defun p2-simple-vector-p (form target representation) - (p2-instanceof-predicate form target representation +lisp-simple-vector-class+)) + (p2-instanceof-predicate form target representation +lisp-simple-vector+)) (defun p2-stringp (form target representation) - (p2-instanceof-predicate form target representation +lisp-abstract-string-class+)) + (p2-instanceof-predicate form target representation +lisp-abstract-string+)) (defun p2-symbolp (form target representation) (p2-instanceof-predicate form target representation +lisp-symbol-class+)) (defun p2-vectorp (form target representation) - (p2-instanceof-predicate form target representation +lisp-abstract-vector-class+)) + (p2-instanceof-predicate form target representation +lisp-abstract-vector+)) (define-inlined-function p2-coerce-to-function (form target representation) ((check-arg-count form 1)) @@ -5680,10 +5670,10 @@ (fixnum-type-p (derive-compiler-type (second form))) (null representation)) (let ((arg (second form))) - (emit 'new +lisp-simple-vector-class+) + (emit 'new +lisp-simple-vector+) (emit 'dup) (compile-forms-and-maybe-emit-clear-values arg 'stack :int) - (emit-invokespecial-init +lisp-simple-vector-class+ '("I")) + (emit-invokespecial-init +lisp-simple-vector+ '("I")) (emit-move-from-stack target representation))) (t (compile-function-call form target representation)))) @@ -5705,9 +5695,9 @@ (class (case result-type ((STRING SIMPLE-STRING) - (setf class +lisp-simple-string-class+)) + (setf class +lisp-simple-string+)) ((VECTOR SIMPLE-VECTOR) - (setf class +lisp-simple-vector-class+))))) + (setf class +lisp-simple-vector+))))) (when class (emit 'new class) (emit 'dup) @@ -5724,10 +5714,10 @@ (= (length form) 2) (null representation)) (let ((arg (second form))) - (emit 'new +lisp-simple-string-class+) + (emit 'new +lisp-simple-string+) (emit 'dup) (compile-forms-and-maybe-emit-clear-values arg 'stack :int) - (emit-invokespecial-init +lisp-simple-string-class+ '("I")) + (emit-invokespecial-init +lisp-simple-string+ '("I")) (emit-move-from-stack target representation))) (t (compile-function-call form target representation)))) @@ -6395,10 +6385,10 @@ (cond ((subtypep type2 'VECTOR) (compile-form arg1 'stack nil) (compile-form arg2 'stack nil) - (emit 'checkcast +lisp-abstract-vector-class+) + (emit 'checkcast +lisp-abstract-vector+) (maybe-emit-clear-values arg1 arg2) (emit 'swap) - (emit-invokevirtual +lisp-abstract-vector-class+ + (emit-invokevirtual +lisp-abstract-vector+ (if (eq test 'eq) "deleteEq" "deleteEql") (lisp-object-arg-types 1) +lisp-object+) (emit-move-from-stack target) @@ -6728,10 +6718,10 @@ (cond ((and (eq representation :char) (zerop *safety*)) (compile-form arg1 'stack nil) - (emit 'checkcast +lisp-abstract-string-class+) + (emit 'checkcast +lisp-abstract-string+) (compile-form arg2 'stack :int) (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string-class+ "charAt" + (emit-invokevirtual +lisp-abstract-string+ "charAt" '("I") "C") (emit-move-from-stack target representation)) ((and (eq representation :char) @@ -6739,10 +6729,10 @@ (compiler-subtypep type1 'STRING) (fixnum-type-p type2)) (compile-form arg1 'stack nil) - (emit 'checkcast +lisp-abstract-string-class+) + (emit 'checkcast +lisp-abstract-string+) (compile-form arg2 'stack :int) (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string-class+ "charAt" + (emit-invokevirtual +lisp-abstract-string+ "charAt" '("I") "C") (emit-move-from-stack target representation)) ((fixnum-type-p type2) @@ -6777,8 +6767,8 @@ (let* ((*register* *register*) (value-register (when target (allocate-register))) (class (if (eq op 'SCHAR) - +lisp-simple-string-class+ - +lisp-abstract-string-class+))) + +lisp-simple-string+ + +lisp-abstract-string+))) (compile-form arg1 'stack nil) (emit 'checkcast class) (compile-form arg2 'stack :int) @@ -6883,10 +6873,10 @@ (:char (cond ((compiler-subtypep type1 'string) (compile-form arg1 'stack nil) ; array - (emit 'checkcast +lisp-abstract-string-class+) + (emit 'checkcast +lisp-abstract-string+) (compile-form arg2 'stack :int) ; index (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string-class+ + (emit-invokevirtual +lisp-abstract-string+ "charAt" '("I") "C")) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil @@ -7230,7 +7220,7 @@ (not (enclosed-by-runtime-bindings-creating-block-p (variable-block variable)))) (aload (variable-binding-register variable)) - (emit 'getfield +lisp-special-binding-class+ "value" + (emit 'getfield +lisp-special-binding+ "value" +lisp-object+)) (t (emit-push-current-thread) @@ -7310,7 +7300,7 @@ (aload (variable-binding-register variable)) (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) (emit 'dup_x1) ;; copy past th - (emit 'putfield +lisp-special-binding-class+ "value" + (emit 'putfield +lisp-special-binding+ "value" +lisp-object+)) ((and (consp value-form) (eq (first value-form) 'CONS) @@ -7464,8 +7454,8 @@ (HASH-TABLE +lisp-hash-table+) (FIXNUM +lisp-fixnum-class+) (STREAM +lisp-stream+) - (STRING +lisp-abstract-string-class+) - (VECTOR +lisp-abstract-vector-class+))) + (STRING +lisp-abstract-string+) + (VECTOR +lisp-abstract-vector+))) (expected-type-java-symbol-name (case expected-type (HASH-TABLE "HASH_TABLE") (t Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Wed Jul 7 18:15:14 2010 @@ -105,29 +105,29 @@ (define-class-name +java-object+ "java.lang.Object") (define-class-name +java-string+ "java.lang.String") (define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject") -(define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString") +(define-class-name +lisp-simple-string+ "org.armedbear.lisp.SimpleString") (define-class-name +lisp+ "org.armedbear.lisp.Lisp") (define-class-name +lisp-nil+ "org.armedbear.lisp.Nil") (define-class-name +lisp-class+ "org.armedbear.lisp.LispClass") (define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol") (define-class-name +lisp-thread+ "org.armedbear.lisp.LispThread") (define-class-name +lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding") -(define-class-name +!lisp-integer+ "org.armedbear.lisp.Integer") +(define-class-name +!lisp-integer+ "org.armedbear.lisp.LispInteger") (define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum") (define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum") (define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat") (define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat") (define-class-name +lisp-cons+ "org.armedbear.lisp.Cons") (define-class-name +lisp-load+ "org.armedbear.lisp.Load") -(define-class-name +!lisp-character+ "org.armedbear.lisp.Character") +(define-class-name +!lisp-character+ "org.armedbear.lisp.LispCharacter") (define-class-name +lisp-structure-object+ "org.armedbear.lisp.StructureObject") -(define-class-name +!lisp-simple-vector+ "org.armedbear.lisp.SimpleVector") -(define-class-name +!lisp-abstract-string+ "org.armedbear.lisp.AbstractString") -(define-class-name +!lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector") -(define-class-name +!lisp-abstract-bit-vector+ +(define-class-name +lisp-simple-vector+ "org.armedbear.lisp.SimpleVector") +(define-class-name +lisp-abstract-string+ "org.armedbear.lisp.AbstractString") +(define-class-name +lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector") +(define-class-name +lisp-abstract-bit-vector+ "org.armedbear.lisp.AbstractBitVector") (define-class-name +lisp-environment+ "org.armedbear.lisp.Environment") -(define-class-name +!lisp-special-binding+ "org.armedbear.lisp.SpecialBinding") +(define-class-name +lisp-special-binding+ "org.armedbear.lisp.SpecialBinding") (define-class-name +lisp-special-bindings-mark+ "org.armedbear.lisp.SpecialBindingsMark") (define-class-name +lisp-throw+ "org.armedbear.lisp.Throw") @@ -141,7 +141,7 @@ (define-class-name +lisp-stream+ "org.armedbear.lisp.Stream") (define-class-name +lisp-closure+ "org.armedbear.lisp.Closure") (define-class-name +lisp-compiled-closure+ "org.armedbear.lisp.CompiledClosure") -(define-class-name +!lisp-closure-parameter+ +(define-class-name +lisp-closure-parameter+ "org.armedbear.lisp.Closure$Parameter") (define-class-name +!fasl-loader+ "org.armedbear.lisp.FaslClassLoader") From ehuelsmann at common-lisp.net Thu Jul 8 21:57:20 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 08 Jul 2010 17:57:20 -0400 Subject: [armedbear-cvs] r12791 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 8 17:57:18 2010 New Revision: 12791 Log: CLASS-NAME integration for +lisp-object+. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp Thu Jul 8 17:57:18 2010 @@ -684,7 +684,7 @@ `(,(1- i) (jvm::with-inline-code () (jvm::emit 'jvm::aload 1) - (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" + (jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance" nil jvm::+java-object+) (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") (jvm::emit 'jvm::dup) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jul 8 17:57:18 2010 @@ -199,8 +199,6 @@ n))) -(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") -(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") @@ -582,12 +580,12 @@ internal representation conversion.") (defvar rep-classes - '((:boolean #.+lisp-object-class+ #.+lisp-object+) - (:char #.+lisp-character-class+ #.+lisp-character+) - (:int #.+lisp-integer-class+ #.+lisp-integer+) - (:long #.+lisp-integer-class+ #.+lisp-integer+) - (:float #.+lisp-single-float-class+ #.+lisp-single-float+) - (:double #.+lisp-double-float-class+ #.+lisp-double-float+)) + `((:boolean . ,+lisp-object+) + (:char . ,+!lisp-character+) + (:int . ,+!lisp-integer+) + (:long . ,+!lisp-integer+) + (:float . ,+!lisp-single-float+) + (:double . ,+!lisp-double-float+)) "Lists the class on which to call the `getInstance' method on, when converting the internal representation to a LispObject.") @@ -612,8 +610,8 @@ (when in (let ((class (cdr (assoc in rep-classes))) (arg-spec (cdr (assoc in rep-arg-chars)))) - (emit-invokestatic (first class) "getInstance" (list arg-spec) - (second class)))) + (emit-invokestatic class "getInstance" (list arg-spec) + class))) (return-from convert-representation)) (let* ((in-map (cdr (assoc in rep-conversion))) (op-num (position out '(:boolean :char :int :long :float :double))) @@ -627,7 +625,7 @@ ((functionp op) (funcall op)) ((stringp op) - (emit-invokevirtual +lisp-object-class+ op nil + (emit-invokevirtual +lisp-object+ op nil (cdr (assoc out rep-arg-chars)))) (t (emit op)))))) @@ -657,7 +655,7 @@ (declaim (ftype (function t string) pretty-java-class)) (defun pretty-java-class (class) - (cond ((equal class +lisp-object-class+) + (cond ((equal (!class-name class) (!class-name +lisp-object+)) "LispObject") ((equal class +lisp-symbol+) "Symbol") @@ -943,17 +941,17 @@ (emit 'checkcast +lisp-fixnum-class+) (emit 'getfield +lisp-fixnum-class+ "value" "I")) (t - (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")))) + (emit-invokevirtual +lisp-object+ "intValue" nil "I")))) ((eq required-representation :char) (emit-unbox-character)) ((eq required-representation :boolean) (emit-unbox-boolean)) ((eq required-representation :long) - (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")) + (emit-invokevirtual +lisp-object+ "longValue" nil "J")) ((eq required-representation :float) - (emit-invokevirtual +lisp-object-class+ "floatValue" nil "F")) + (emit-invokevirtual +lisp-object+ "floatValue" nil "F")) ((eq required-representation :double) - (emit-invokevirtual +lisp-object-class+ "doubleValue" nil "D")) + (emit-invokevirtual +lisp-object+ "doubleValue" nil "D")) (t (assert nil)))) (defknown emit-move-from-stack (t &optional t) t) @@ -983,7 +981,7 @@ ;; Expects value on stack. (defknown emit-invoke-method (t t t) t) (defun emit-invoke-method (method-name target representation) - (emit-invokevirtual +lisp-object-class+ method-name nil +lisp-object+) + (emit-invokevirtual +lisp-object+ method-name nil +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -2121,9 +2119,9 @@ (double-float "DBL" ,#'eql ,#'serialize-double ,+!lisp-double-float+) (string "STR" ,#'equal ,#'serialize-string ,+lisp-abstract-string+) ;; because of (not compile-file) - (package "PKG" ,#'eq ,#'serialize-package ,+!lisp-object+) + (package "PKG" ,#'eq ,#'serialize-package ,+lisp-object+) (symbol "SYM" ,#'eq ,#'serialize-symbol ,+!lisp-symbol+) - (T "OBJ" ,#'eq ,#'serialize-object ,+!lisp-object+)) + (T "OBJ" ,#'eq ,#'serialize-object ,+lisp-object+)) "A list of 5-element lists. The elements of the sublists mean: 1. The type of the value to be serialized @@ -2176,7 +2174,7 @@ (emit 'ldc (pool-string field-name)) (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) - (when (not (eq field-type +!lisp-object+)) + (when (not (eq field-type +lisp-object+)) (emit 'checkcast field-type)) (emit 'putstatic *this-class* field-name field-type) (setf *static-code* *code*))) @@ -2231,7 +2229,7 @@ nil +lisp-object+) ;; make sure we're not cacheing a proxied function ;; (AutoloadedFunctionProxy) by allowing it to resolve itself - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ "resolve" nil +lisp-object+) (emit 'putstatic *this-class* f +lisp-object+) (if *declare-inline* @@ -2324,9 +2322,8 @@ (setf *code* saved-code)) g)) -(declaim (ftype (function (t &optional t) string) declare-object)) -(defun declare-object (obj &optional (obj-ref +lisp-object+) - obj-class) +(declaim (ftype (function (t) string) declare-object)) +(defun declare-object (obj) "Stores the object OBJ in the object-lookup-table, loading the object value into a field upon class-creation time. @@ -2335,13 +2332,11 @@ ;; fixme *declare-inline*? (remember g obj) (let* ((*code* *static-code*)) - (declare-field g obj-ref +field-access-private+) + (declare-field g +lisp-object+ +field-access-private+) (emit 'ldc (pool-string g)) (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) - (when (and obj-class (string/= obj-class +lisp-object-class+)) - (emit 'checkcast obj-class)) - (emit 'putstatic *this-class* g obj-ref) + (emit 'putstatic *this-class* g +lisp-object+) (setf *static-code* *code*) g))) @@ -2355,7 +2350,7 @@ (emit-push-constant-int form)) ((integerp form) (emit-load-externalized-object form) - (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")) + (emit-invokevirtual +lisp-object+ "intValue" nil "I")) (t (sys::%format t "compile-constant int representation~%") (assert nil))) @@ -2366,7 +2361,7 @@ (emit-push-constant-long form)) ((integerp form) (emit-load-externalized-object form) - (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")) + (emit-invokevirtual +lisp-object+ "longValue" nil "J")) (t (sys::%format t "compile-constant long representation~%") (assert nil))) @@ -2492,11 +2487,11 @@ (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (ecase representation (:boolean - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ unboxed-method-name nil "Z")) ((NIL) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ boxed-method-name nil +lisp-object+))) (emit-move-from-stack target representation))) @@ -2564,7 +2559,7 @@ (arg2 (cadr args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ op + (emit-invokevirtual +lisp-object+ op (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -2629,7 +2624,7 @@ t) (defun emit-ifne-for-eql (representation instruction-type) - (emit-invokevirtual +lisp-object-class+ "eql" instruction-type "Z") + (emit-invokevirtual +lisp-object+ "eql" instruction-type "Z") (convert-representation :boolean representation)) (defknown p2-eql (t t t) t) @@ -2675,10 +2670,10 @@ arg2 'stack nil) (ecase representation (:boolean - (emit-invokevirtual +lisp-object-class+ "eql" + (emit-invokevirtual +lisp-object+ "eql" (lisp-object-arg-types 1) "Z")) ((NIL) - (emit-invokevirtual +lisp-object-class+ "EQL" + (emit-invokevirtual +lisp-object+ "EQL" (lisp-object-arg-types 1) +lisp-object+))))) (emit-move-from-stack target representation))) @@ -2843,7 +2838,7 @@ (setf must-clear-values t))))) (t (emit-push-constant-int numargs) - (emit 'anewarray +lisp-object-class+) + (emit 'anewarray +lisp-object+) (let ((i 0)) (dolist (arg args) (emit 'dup) @@ -2876,7 +2871,7 @@ (lisp-object-arg-types numargs) (list +lisp-object-array+))) (return-type +lisp-object+)) - (emit-invokevirtual +lisp-object-class+ "execute" arg-types return-type))) + (emit-invokevirtual +lisp-object+ "execute" arg-types return-type))) (declaim (ftype (function (t) t) emit-call-thread-execute)) (defun emit-call-thread-execute (numargs) @@ -3141,7 +3136,7 @@ ((fixnump arg2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-constant-int arg2) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (case op (< "isLessThan") (<= "isLessThanOrEqualTo") @@ -3274,7 +3269,7 @@ (when (check-arg-count form 1) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-invokevirtual +lisp-object-class+ java-predicate nil "Z") + (emit-invokevirtual +lisp-object+ java-predicate nil "Z") 'ifeq))) (declaim (ftype (function (t t) t) p2-test-instanceof-predicate)) @@ -3296,7 +3291,7 @@ (when (= (length form) 2) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-invokevirtual +lisp-object-class+ "constantp" nil "Z") + (emit-invokevirtual +lisp-object+ "constantp" nil "Z") 'ifeq))) (defun p2-test-endp (form) @@ -3487,29 +3482,29 @@ ((eq type2 'CHARACTER) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :char) - (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z") + (emit-invokevirtual +lisp-object+ "eql" '("C") "Z") 'ifeq) ((eq type1 'CHARACTER) (compile-forms-and-maybe-emit-clear-values arg1 'stack :char arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z") + (emit-invokevirtual +lisp-object+ "eql" '("C") "Z") 'ifeq) ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") + (emit-invokevirtual +lisp-object+ "eql" '("I") "Z") 'ifeq) ((fixnum-type-p type1) (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") + (emit-invokevirtual +lisp-object+ "eql" '("I") "Z") 'ifeq) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "eql" + (emit-invokevirtual +lisp-object+ "eql" (lisp-object-arg-types 1) "Z") 'ifeq))))) @@ -3524,13 +3519,13 @@ (cond ((fixnum-type-p (derive-compiler-type arg2)) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ translated-op '("I") "Z")) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ translated-op (lisp-object-arg-types 1) "Z"))) 'ifeq))) @@ -3541,7 +3536,7 @@ (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "typep" + (emit-invokevirtual +lisp-object+ "typep" (lisp-object-arg-types 1) +lisp-object+) (emit-push-nil) 'if_acmpeq))) @@ -3582,7 +3577,7 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z") + (emit-invokevirtual +lisp-object+ "isNotEqualTo" '("I") "Z") 'ifeq) ((fixnum-type-p type1) ;; FIXME Compile the args in reverse order and avoid the swap if @@ -3590,12 +3585,12 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z") + (emit-invokevirtual +lisp-object+ "isNotEqualTo" '("I") "Z") 'ifeq) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" + (emit-invokevirtual +lisp-object+ "isNotEqualTo" (lisp-object-arg-types 1) "Z") 'ifeq))))) @@ -3632,7 +3627,7 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") (<= "isLessThanOrEqualTo") @@ -3647,7 +3642,7 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (ecase op (< "isGreaterThan") (<= "isGreaterThanOrEqualTo") @@ -3659,7 +3654,7 @@ (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") (<= "isLessThanOrEqualTo") @@ -3840,7 +3835,7 @@ (compile-form (second form) 'stack nil) (emit-invokestatic +lisp+ "coerceToFunction" (lisp-object-arg-types 1) +lisp-object+) - (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+)) + (emit-invokevirtual +lisp-object+ "execute" nil +lisp-object+)) (3 (let* ((*register* *register*) (function-register (allocate-register))) @@ -3874,7 +3869,7 @@ (maybe-emit-clear-values values-form)) (aload function-register) (aload values-register) - (emit-invokevirtual +lisp-object-class+ "dispatch" + (emit-invokevirtual +lisp-object+ "dispatch" (list +lisp-object-array+) +lisp-object+)))) (fix-boxing representation nil) (emit-move-from-stack target)) @@ -4458,9 +4453,9 @@ (when (tagbody-id-variable block) ;; we have a block variable; that should be a closure variable (assert (not (null (variable-closure-index (tagbody-id-variable block))))) - (emit 'new +lisp-object-class+) + (emit 'new +lisp-object+) (emit 'dup) - (emit-invokespecial-init +lisp-object-class+ '()) + (emit-invokespecial-init +lisp-object+ '()) (emit-new-closure-binding (tagbody-id-variable block))) (label BEGIN-BLOCK) (do* ((rest body (cdr rest)) @@ -4656,9 +4651,9 @@ (when (block-id-variable block) ;; we have a block variable; that should be a closure variable (assert (not (null (variable-closure-index (block-id-variable block))))) - (emit 'new +lisp-object-class+) + (emit 'new +lisp-object+) (emit 'dup) - (emit-invokespecial-init +lisp-object-class+ '()) + (emit-invokespecial-init +lisp-object+ '()) (emit-new-closure-binding (block-id-variable block))) (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) @@ -4844,7 +4839,7 @@ (when target (emit 'dup)) (compile-form (second args) 'stack nil) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ "setCdr" (lisp-object-arg-types 1) nil) @@ -4860,7 +4855,7 @@ (compile-form (%cadr args) 'stack nil) (when target (emit-dup nil :past nil)) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (if (eq op 'sys:set-car) "setCar" "setCdr") (lisp-object-arg-types 1) nil) @@ -5063,7 +5058,7 @@ (emit-move-from-stack target)) (t (emit-load-externalized-object name) - (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie" + (emit-invokevirtual +lisp-object+ "getSymbolFunctionOrDie" nil +lisp-object+) (emit-move-from-stack target)))) ((and (consp name) (eq (%car name) 'SETF)) @@ -5197,7 +5192,7 @@ (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "ash" '("I") +lisp-object+) (fix-boxing representation result-type))) (emit-move-from-stack target representation)) (t @@ -5261,7 +5256,7 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "LOGAND" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGAND" '("I") +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) ((fixnum-type-p type1) @@ -5270,13 +5265,13 @@ arg2 'stack nil) ;; swap args (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "LOGAND" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGAND" '("I") +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "LOGAND" + (emit-invokevirtual +lisp-object+ "LOGAND" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation))))) @@ -5333,7 +5328,7 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "LOGIOR" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGIOR" '("I") +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) ((fixnum-type-p type1) @@ -5342,13 +5337,13 @@ arg2 'stack nil) ;; swap args (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "LOGIOR" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGIOR" '("I") +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "LOGIOR" + (emit-invokevirtual +lisp-object+ "LOGIOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation))))) @@ -5397,12 +5392,12 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "LOGXOR" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGXOR" '("I") +lisp-object+) (fix-boxing representation result-type)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "LOGXOR" + (emit-invokevirtual +lisp-object+ "LOGXOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type))) (emit-move-from-stack target representation))) @@ -5424,7 +5419,7 @@ (t (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil)) - (emit-invokevirtual +lisp-object-class+ "LOGNOT" nil +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGNOT" nil +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)))) @@ -5481,7 +5476,7 @@ (compile-forms-and-maybe-emit-clear-values arg3 'stack nil) (emit-push-constant-int size) (emit-push-constant-int position) - (emit-invokevirtual +lisp-object-class+ "LDB" '("I" "I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LDB" '("I" "I") +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)))) ((and (fixnum-type-p size-type) @@ -5491,7 +5486,7 @@ arg3 'stack nil) (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved (emit 'pop) - (emit-invokevirtual +lisp-object-class+ "LDB" '("I" "I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LDB" '("I" "I") +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t @@ -5515,13 +5510,13 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "MOD" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "MOD" '("I") +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "MOD" + (emit-invokevirtual +lisp-object+ "MOD" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))))) @@ -5616,12 +5611,12 @@ arg2 'stack nil) (emit 'swap) (cond (target - (emit-invokevirtual +lisp-object-class+ "VECTOR_PUSH_EXTEND" + (emit-invokevirtual +lisp-object+ "VECTOR_PUSH_EXTEND" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t - (emit-invokevirtual +lisp-object-class+ "vectorPushExtend" + (emit-invokevirtual +lisp-object+ "vectorPushExtend" (lisp-object-arg-types 1) nil)))) (t (compile-function-call form target representation))))) @@ -5634,7 +5629,7 @@ (arg2 (second args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "SLOT_VALUE" + (emit-invokevirtual +lisp-object+ "SLOT_VALUE" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -5655,7 +5650,7 @@ (when value-register (emit 'dup) (astore value-register)) - (emit-invokevirtual +lisp-object-class+ "setSlotValue" + (emit-invokevirtual +lisp-object+ "setSlotValue" (lisp-object-arg-types 2) nil) (when value-register (aload value-register) @@ -5731,7 +5726,7 @@ (emit 'checkcast +lisp-symbol-class+) (compile-form (%caddr form) 'stack nil) (maybe-emit-clear-values (%cadr form) (%caddr form)) - (emit-invokevirtual +lisp-object-class+ "copyToArray" + (emit-invokevirtual +lisp-object+ "copyToArray" nil +lisp-object-array+) (emit-invokespecial-init +lisp-structure-object+ (list +lisp-symbol+ +lisp-object-array+)) @@ -6403,20 +6398,20 @@ (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (ecase representation (:int - (emit-invokevirtual +lisp-object-class+ "length" nil "I")) + (emit-invokevirtual +lisp-object+ "length" nil "I")) ((:long :float :double) - (emit-invokevirtual +lisp-object-class+ "length" nil "I") + (emit-invokevirtual +lisp-object+ "length" nil "I") (convert-representation :int representation)) (:boolean ;; FIXME We could optimize this all away in unsafe calls. - (emit-invokevirtual +lisp-object-class+ "length" nil "I") + (emit-invokevirtual +lisp-object+ "length" nil "I") (emit 'pop) (emit 'iconst_1)) (:char (sys::%format t "p2-length: :char case~%") (aver nil)) ((nil) - (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+))) + (emit-invokevirtual +lisp-object+ "LENGTH" nil +lisp-object+))) (emit-move-from-stack target representation))) (defun cons-for-list/list* (form target representation &optional list-star-p) @@ -6466,7 +6461,7 @@ (compile-forms-and-maybe-emit-clear-values index-form 'stack :int list-form 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "NTH" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "NTH" '("I") +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))) @@ -6505,7 +6500,7 @@ ((fixnump arg2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-int arg2) - (emit-invokevirtual +lisp-object-class+ "multiplyBy" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "multiplyBy" '("I") +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t @@ -6555,7 +6550,7 @@ (emit-dup nil) (compile-form arg2 'stack nil) (emit-dup nil :past nil) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (if (eq op 'max) "isLessThanOrEqualTo" "isGreaterThanOrEqualTo") @@ -6623,7 +6618,7 @@ arg2 'stack (when (null (fixnum-type-p type1)) :int)) (when (fixnum-type-p type1) (emit 'swap)) - (emit-invokevirtual +lisp-object-class+ "add" + (emit-invokevirtual +lisp-object+ "add" '("I") +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) @@ -6662,7 +6657,7 @@ (emit-move-from-stack target representation)) (t (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-invokevirtual +lisp-object-class+ "negate" + (emit-invokevirtual +lisp-object+ "negate" nil +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))))) @@ -6694,7 +6689,7 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ "subtract" '("I") +lisp-object+) (fix-boxing representation result-type) @@ -6738,7 +6733,7 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (symbol-name op) ;; "CHAR" or "SCHAR" '("I") +lisp-object+) (when (eq representation :char) @@ -6793,7 +6788,7 @@ (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "SVREF" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "SVREF" '("I") +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) (t @@ -6813,7 +6808,7 @@ (emit 'dup) (emit-move-from-stack value-register nil)) (maybe-emit-clear-values arg1 arg2 arg3) - (emit-invokevirtual +lisp-object-class+ "svset" (list "I" +lisp-object+) nil) + (emit-invokevirtual +lisp-object+ "svset" (list "I" +lisp-object+) nil) (when value-register (aload value-register) (emit-move-from-stack target nil)))) @@ -6838,7 +6833,7 @@ (return-from p2-truncate))) (compile-form arg1 'stack nil) (compile-form arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "truncate" (lisp-object-arg-types 1) +lisp-object+) + (emit-invokevirtual +lisp-object+ "truncate" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))) @@ -6848,7 +6843,7 @@ (neq representation :char)) ; FIXME (compile-form (second form) 'stack nil) (compile-form (third form) 'stack :int) - (emit-invokevirtual +lisp-object-class+ "elt" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "elt" '("I") +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation)) (t @@ -6865,11 +6860,11 @@ (:int (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "aref" '("I") "I")) + (emit-invokevirtual +lisp-object+ "aref" '("I") "I")) (:long (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "aref_long" '("I") "J")) + (emit-invokevirtual +lisp-object+ "aref_long" '("I") "J")) (:char (cond ((compiler-subtypep type1 'string) (compile-form arg1 'stack nil) ; array @@ -6881,14 +6876,14 @@ (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "AREF" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "AREF" '("I") +lisp-object+) (emit-unbox-character)))) ((nil :float :double :boolean) ;;###FIXME for float and double, we probably want ;; separate java methods to retrieve the values. (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "AREF" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "AREF" '("I") +lisp-object+) (convert-representation nil representation))) (emit-move-from-stack target representation))) (t @@ -6921,9 +6916,9 @@ (emit-move-from-stack value-register nil)))) (maybe-emit-clear-values arg1 arg2 arg3) (cond ((fixnum-type-p type3) - (emit-invokevirtual +lisp-object-class+ "aset" '("I" "I") nil)) + (emit-invokevirtual +lisp-object+ "aset" '("I" "I") nil)) (t - (emit-invokevirtual +lisp-object-class+ "aset" (list "I" +lisp-object+) nil))) + (emit-invokevirtual +lisp-object+ "aset" (list "I" +lisp-object+) nil))) (when value-register (cond ((fixnum-type-p type3) (emit 'iload value-register) @@ -6946,20 +6941,20 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (case arg2 (0 - (emit-invokevirtual +lisp-object-class+ "getSlotValue_0" + (emit-invokevirtual +lisp-object+ "getSlotValue_0" nil +lisp-object+)) (1 - (emit-invokevirtual +lisp-object-class+ "getSlotValue_1" + (emit-invokevirtual +lisp-object+ "getSlotValue_1" nil +lisp-object+)) (2 - (emit-invokevirtual +lisp-object-class+ "getSlotValue_2" + (emit-invokevirtual +lisp-object+ "getSlotValue_2" nil +lisp-object+)) (3 - (emit-invokevirtual +lisp-object-class+ "getSlotValue_3" + (emit-invokevirtual +lisp-object+ "getSlotValue_3" nil +lisp-object+)) (t (emit-push-constant-int arg2) - (emit-invokevirtual +lisp-object-class+ "getSlotValue" + (emit-invokevirtual +lisp-object+ "getSlotValue" '("I") +lisp-object+))) (emit-move-from-stack target representation)) ((fixnump arg2) @@ -6967,15 +6962,15 @@ (emit-push-constant-int arg2) (ecase representation (:int - (emit-invokevirtual +lisp-object-class+ "getFixnumSlotValue" + (emit-invokevirtual +lisp-object+ "getFixnumSlotValue" '("I") "I")) ((nil :char :long :float :double) - (emit-invokevirtual +lisp-object-class+ "getSlotValue" + (emit-invokevirtual +lisp-object+ "getSlotValue" '("I") +lisp-object+) ;; (convert-representation NIL NIL) is a no-op (convert-representation nil representation)) (:boolean - (emit-invokevirtual +lisp-object-class+ "getSlotValueAsBoolean" + (emit-invokevirtual +lisp-object+ "getSlotValueAsBoolean" '("I") "Z"))) (emit-move-from-stack target representation)) (t @@ -6997,7 +6992,7 @@ (when value-register (emit 'dup) (astore value-register)) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (format nil "setSlotValue_~D" arg2) (lisp-object-arg-types 1) nil) (when value-register @@ -7014,7 +7009,7 @@ (when value-register (emit 'dup) (astore value-register)) - (emit-invokevirtual +lisp-object-class+ "setSlotValue" + (emit-invokevirtual +lisp-object+ "setSlotValue" (list "I" +lisp-object+) nil) (when value-register (aload value-register) @@ -7080,7 +7075,7 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "nthcdr" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "nthcdr" '("I") +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t @@ -7395,7 +7390,7 @@ (cond ((check-arg-count form 1) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-invokevirtual +lisp-object-class+ "sxhash" nil "I") + (emit-invokevirtual +lisp-object+ "sxhash" nil "I") (convert-representation :int representation) (emit-move-from-stack target representation))) (t @@ -7616,7 +7611,7 @@ (END-PROTECTED-RANGE (gensym)) (EXIT (gensym))) (compile-form (cadr form) 'stack nil) - (emit-invokevirtual +lisp-object-class+ "lockableInstance" nil + (emit-invokevirtual +lisp-object+ "lockableInstance" nil +java-object+) ; value to synchronize (emit 'dup) (astore object-register) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Thu Jul 8 17:57:18 2010 @@ -104,7 +104,7 @@ (define-class-name +java-object+ "java.lang.Object") (define-class-name +java-string+ "java.lang.String") -(define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject") +(define-class-name +lisp-object+ "org.armedbear.lisp.LispObject") (define-class-name +lisp-simple-string+ "org.armedbear.lisp.SimpleString") (define-class-name +lisp+ "org.armedbear.lisp.Lisp") (define-class-name +lisp-nil+ "org.armedbear.lisp.Nil") From ehuelsmann at common-lisp.net Thu Jul 8 22:15:44 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 08 Jul 2010 18:15:44 -0400 Subject: [armedbear-cvs] r12792 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 8 18:15:43 2010 New Revision: 12792 Log: CLASS-NAME integration for +lisp-symbol+. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jul 8 18:15:43 2010 @@ -201,8 +201,6 @@ (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") -(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") -(defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") (defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger") (defconstant +lisp-integer+ "Lorg/armedbear/lisp/LispInteger;") (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum") @@ -744,7 +742,7 @@ (unless (local-variable-p variable) (return-from generate-instanceof-type-check-for-variable)) (let ((instanceof-class (ecase expected-type - (SYMBOL +lisp-symbol-class+) + (SYMBOL +lisp-symbol+) (CHARACTER +lisp-character-class+) (CONS +lisp-cons+) (HASH-TABLE +lisp-hash-table+) @@ -761,7 +759,7 @@ (emit 'instanceof instanceof-class) (emit 'ifne LABEL1) (emit-load-local-variable variable) - (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name + (emit 'getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+) (emit-invokestatic +lisp+ "type_error" (lisp-object-arg-types 2) +lisp-object+) @@ -2100,7 +2098,7 @@ (emit-push-constant-int (dump-uninterned-symbol-index symbol)) (emit-invokestatic +lisp-load+ "getUninternedSymbol" '("I") +lisp-object+) - (emit 'checkcast +lisp-symbol-class+)) + (emit 'checkcast +lisp-symbol+)) ((keywordp symbol) (emit 'ldc (pool-string (symbol-name symbol))) (emit-invokestatic +lisp+ "internKeyword" @@ -2120,7 +2118,7 @@ (string "STR" ,#'equal ,#'serialize-string ,+lisp-abstract-string+) ;; because of (not compile-file) (package "PKG" ,#'eq ,#'serialize-package ,+lisp-object+) - (symbol "SYM" ,#'eq ,#'serialize-symbol ,+!lisp-symbol+) + (symbol "SYM" ,#'eq ,#'serialize-symbol ,+lisp-symbol+) (T "OBJ" ,#'eq ,#'serialize-object ,+lisp-object+)) "A list of 5-element lists. The elements of the sublists mean: @@ -2220,9 +2218,9 @@ (if (eq class *this-class*) (progn ;; generated by the DECLARE-OBJECT*'s above (emit 'getstatic class name +lisp-object+) - (emit 'checkcast +lisp-symbol-class+)) + (emit 'checkcast +lisp-symbol+)) (emit 'getstatic class name +lisp-symbol+)) - (emit-invokevirtual +lisp-symbol-class+ + (emit-invokevirtual +lisp-symbol+ (if setf "getSymbolSetfFunctionOrDie" "getSymbolFunctionOrDie") @@ -3367,7 +3365,7 @@ (p2-test-predicate form "isSpecialVariable")) (defun p2-test-symbolp (form) - (p2-test-instanceof-predicate form +lisp-symbol-class+)) + (p2-test-instanceof-predicate form +lisp-symbol+)) (defun p2-test-consp (form) (p2-test-instanceof-predicate form +lisp-cons+)) @@ -4626,7 +4624,7 @@ (p2-instanceof-predicate form target representation +lisp-abstract-string+)) (defun p2-symbolp (form target representation) - (p2-instanceof-predicate form target representation +lisp-symbol-class+)) + (p2-instanceof-predicate form target representation +lisp-symbol+)) (defun p2-vectorp (form target representation) (p2-instanceof-predicate form target representation +lisp-abstract-vector+)) @@ -5097,7 +5095,7 @@ (emit-move-from-stack target)) (t (emit-load-externalized-object (cadr name)) - (emit-invokevirtual +lisp-symbol-class+ + (emit-invokevirtual +lisp-symbol+ "getSymbolSetfFunctionOrDie" nil +lisp-object+) (emit-move-from-stack target)))) @@ -5723,7 +5721,7 @@ (emit 'new +lisp-structure-object+) (emit 'dup) (compile-form (%cadr form) 'stack nil) - (emit 'checkcast +lisp-symbol-class+) + (emit 'checkcast +lisp-symbol+) (compile-form (%caddr form) 'stack nil) (maybe-emit-clear-values (%cadr form) (%caddr form)) (emit-invokevirtual +lisp-object+ "copyToArray" @@ -5743,7 +5741,7 @@ (emit 'new +lisp-structure-object+) (emit 'dup) (compile-form (%car args) 'stack nil) - (emit 'checkcast +lisp-symbol-class+) + (emit 'checkcast +lisp-symbol+) (dolist (slot-form slot-forms) (compile-form slot-form 'stack nil)) (apply 'maybe-emit-clear-values args) @@ -7208,7 +7206,7 @@ (cond ((constantp name) ;; "... a reference to a symbol declared with DEFCONSTANT always ;; refers to its global value." - (emit-invokevirtual +lisp-symbol-class+ "getSymbolValue" + (emit-invokevirtual +lisp-symbol+ "getSymbolValue" nil +lisp-object+)) ((and (variable-binding-register variable) (eq (variable-compiland variable) *current-compiland*) @@ -7219,7 +7217,7 @@ +lisp-object+)) (t (emit-push-current-thread) - (emit-invokevirtual +lisp-symbol-class+ "symbolValue" + (emit-invokevirtual +lisp-symbol+ "symbolValue" (list +lisp-thread+) +lisp-object+))) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -7250,7 +7248,7 @@ (eq (derive-type (%cadr form)) 'SYMBOL)) (emit-push-current-thread) (compile-form (%cadr form) 'stack nil) - (emit 'checkcast +lisp-symbol-class+) + (emit 'checkcast +lisp-symbol+) (compile-form (%caddr form) 'stack nil) (maybe-emit-clear-values (%cadr form) (%caddr form)) (emit-invokevirtual +lisp-thread+ "setSpecialVariable" @@ -7402,8 +7400,8 @@ (let ((arg (%cadr form))) (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'checkcast +lisp-symbol-class+) - (emit 'getfield +lisp-symbol-class+ "name" +lisp-simple-string+) + (emit 'checkcast +lisp-symbol+) + (emit 'getfield +lisp-symbol+ "name" +lisp-simple-string+) (emit-move-from-stack target representation)) (t (compile-function-call form target representation))))) @@ -7414,8 +7412,8 @@ (let ((arg (%cadr form))) (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'checkcast +lisp-symbol-class+) - (emit-invokevirtual +lisp-symbol-class+ "getPackage" + (emit 'checkcast +lisp-symbol+) + (emit-invokevirtual +lisp-symbol+ "getPackage" nil +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -7428,9 +7426,9 @@ (let ((arg (%cadr form))) (when (eq (derive-compiler-type arg) 'SYMBOL) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'checkcast +lisp-symbol-class+) + (emit 'checkcast +lisp-symbol+) (emit-push-current-thread) - (emit-invokevirtual +lisp-symbol-class+ "symbolValue" + (emit-invokevirtual +lisp-symbol+ "symbolValue" (list +lisp-thread+) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation) @@ -7443,7 +7441,7 @@ ;; The value to be checked is on the stack. (declare (type symbol expected-type)) (let ((instanceof-class (ecase expected-type - (SYMBOL +lisp-symbol-class+) + (SYMBOL +lisp-symbol+) (CHARACTER +lisp-character-class+) (CONS +lisp-cons+) (HASH-TABLE +lisp-hash-table+) @@ -7459,7 +7457,7 @@ (emit 'dup) (emit 'instanceof instanceof-class) (emit 'ifne LABEL1) - (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) + (emit 'getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+) (emit-invokestatic +lisp+ "type_error" (lisp-object-arg-types 2) +lisp-object+) (label LABEL1)) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Thu Jul 8 18:15:43 2010 @@ -109,7 +109,7 @@ (define-class-name +lisp+ "org.armedbear.lisp.Lisp") (define-class-name +lisp-nil+ "org.armedbear.lisp.Nil") (define-class-name +lisp-class+ "org.armedbear.lisp.LispClass") -(define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol") +(define-class-name +lisp-symbol+ "org.armedbear.lisp.Symbol") (define-class-name +lisp-thread+ "org.armedbear.lisp.LispThread") (define-class-name +lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding") (define-class-name +!lisp-integer+ "org.armedbear.lisp.LispInteger") From ehuelsmann at common-lisp.net Thu Jul 8 22:18:06 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 08 Jul 2010 18:18:06 -0400 Subject: [armedbear-cvs] r12793 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 8 18:18:06 2010 New Revision: 12793 Log: Remove commented-out code. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jul 8 18:18:06 2010 @@ -206,8 +206,6 @@ (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum") (defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;") (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;") -;(defconstant +lisp-function-proxy-class+ -; "org/armedbear/lisp/AutoloadedFunctionProxy") (defconstant +lisp-bignum-class+ "org/armedbear/lisp/Bignum") (defconstant +lisp-bignum+ "Lorg/armedbear/lisp/Bignum;") (defconstant +lisp-single-float-class+ "org/armedbear/lisp/SingleFloat") @@ -2256,15 +2254,6 @@ (emit 'new class-name) (emit 'dup) (emit-invokespecial-init class-name '()) - - ;(emit 'ldc (pool-string (pathname-name pathname))) - ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction" - ;(list +java-string+) +lisp-object+) - -; (emit 'ldc (pool-string (file-namestring pathname))) - -; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" -; (list +java-string+) +lisp-object+) (emit 'putstatic *this-class* g +lisp-object+) (setf *static-code* *code*) (setf (gethash local-function ht) g)))) From ehuelsmann at common-lisp.net Thu Jul 8 22:27:22 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 08 Jul 2010 18:27:22 -0400 Subject: [armedbear-cvs] r12794 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 8 18:27:21 2010 New Revision: 12794 Log: CLASS-NAME integration for +lisp-character+. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jul 8 18:27:21 2010 @@ -212,8 +212,6 @@ (defconstant +lisp-single-float+ "Lorg/armedbear/lisp/SingleFloat;") (defconstant +lisp-double-float-class+ "org/armedbear/lisp/DoubleFloat") (defconstant +lisp-double-float+ "Lorg/armedbear/lisp/DoubleFloat;") -(defconstant +lisp-character-class+ "org/armedbear/lisp/LispCharacter") -(defconstant +lisp-character+ "Lorg/armedbear/lisp/LispCharacter;") (defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;") (defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;") @@ -554,11 +552,11 @@ (defknown emit-unbox-character () t) (defun emit-unbox-character () (cond ((> *safety* 0) - (emit-invokestatic +lisp-character-class+ "getValue" + (emit-invokestatic +lisp-character+ "getValue" (lisp-object-arg-types 1) "C")) (t - (emit 'checkcast +lisp-character-class+) - (emit 'getfield +lisp-character-class+ "value" "C")))) + (emit 'checkcast +lisp-character+) + (emit 'getfield +lisp-character+ "value" "C")))) ;; source type / ;; targets :boolean :char :int :long :float :double @@ -577,7 +575,7 @@ (defvar rep-classes `((:boolean . ,+lisp-object+) - (:char . ,+!lisp-character+) + (:char . ,+lisp-character+) (:int . ,+!lisp-integer+) (:long . ,+!lisp-integer+) (:float . ,+!lisp-single-float+) @@ -741,7 +739,7 @@ (return-from generate-instanceof-type-check-for-variable)) (let ((instanceof-class (ecase expected-type (SYMBOL +lisp-symbol+) - (CHARACTER +lisp-character-class+) + (CHARACTER +lisp-character+) (CONS +lisp-cons+) (HASH-TABLE +lisp-hash-table+) (FIXNUM +lisp-fixnum-class+) @@ -2044,7 +2042,7 @@ (defun serialize-character (c) "Generates code to restore a serialized character." (emit-push-constant-int (char-code c)) - (emit-invokestatic +lisp-character-class+ "getInstance" '("C") + (emit-invokestatic +lisp-character+ "getInstance" '("C") +lisp-character+)) (defun serialize-float (s) @@ -2110,7 +2108,7 @@ (defvar serialization-table `((integer "INT" ,#'eql ,#'serialize-integer ,+!lisp-integer+) - (character "CHR" ,#'eql ,#'serialize-character ,+!lisp-character+) + (character "CHR" ,#'eql ,#'serialize-character ,+lisp-character+) (single-float "FLT" ,#'eql ,#'serialize-float ,+!lisp-single-float+) (double-float "DBL" ,#'eql ,#'serialize-double ,+!lisp-double-float+) (string "STR" ,#'equal ,#'serialize-string @@ -3271,7 +3269,7 @@ (p2-test-instanceof-predicate form +lisp-abstract-bit-vector+)) (defun p2-test-characterp (form) - (p2-test-instanceof-predicate form +lisp-character-class+)) + (p2-test-instanceof-predicate form +lisp-character+)) ;; constantp form &optional environment => generalized-boolean (defun p2-test-constantp (form) @@ -4592,7 +4590,7 @@ (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector+)) (defun p2-characterp (form target representation) - (p2-instanceof-predicate form target representation +lisp-character-class+)) + (p2-instanceof-predicate form target representation +lisp-character+)) (defun p2-consp (form target representation) (p2-instanceof-predicate form target representation +lisp-cons+)) @@ -7431,7 +7429,7 @@ (declare (type symbol expected-type)) (let ((instanceof-class (ecase expected-type (SYMBOL +lisp-symbol+) - (CHARACTER +lisp-character-class+) + (CHARACTER +lisp-character+) (CONS +lisp-cons+) (HASH-TABLE +lisp-hash-table+) (FIXNUM +lisp-fixnum-class+) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Thu Jul 8 18:27:21 2010 @@ -119,7 +119,7 @@ (define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat") (define-class-name +lisp-cons+ "org.armedbear.lisp.Cons") (define-class-name +lisp-load+ "org.armedbear.lisp.Load") -(define-class-name +!lisp-character+ "org.armedbear.lisp.LispCharacter") +(define-class-name +lisp-character+ "org.armedbear.lisp.LispCharacter") (define-class-name +lisp-structure-object+ "org.armedbear.lisp.StructureObject") (define-class-name +lisp-simple-vector+ "org.armedbear.lisp.SimpleVector") (define-class-name +lisp-abstract-string+ "org.armedbear.lisp.AbstractString") From ehuelsmann at common-lisp.net Thu Jul 8 22:50:03 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 08 Jul 2010 18:50:03 -0400 Subject: [armedbear-cvs] r12795 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 8 18:50:02 2010 New Revision: 12795 Log: CLASS-NAME integration for +lisp-integer+. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jul 8 18:50:02 2010 @@ -201,8 +201,6 @@ (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") -(defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger") -(defconstant +lisp-integer+ "Lorg/armedbear/lisp/LispInteger;") (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum") (defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;") (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;") @@ -576,8 +574,8 @@ (defvar rep-classes `((:boolean . ,+lisp-object+) (:char . ,+lisp-character+) - (:int . ,+!lisp-integer+) - (:long . ,+!lisp-integer+) + (:int . ,+lisp-integer+) + (:long . ,+lisp-integer+) (:float . ,+!lisp-single-float+) (:double . ,+!lisp-double-float+)) "Lists the class on which to call the `getInstance' method on, @@ -2107,7 +2105,7 @@ +lisp-symbol+))))) (defvar serialization-table - `((integer "INT" ,#'eql ,#'serialize-integer ,+!lisp-integer+) + `((integer "INT" ,#'eql ,#'serialize-integer ,+lisp-integer+) (character "CHR" ,#'eql ,#'serialize-character ,+lisp-character+) (single-float "FLT" ,#'eql ,#'serialize-float ,+!lisp-single-float+) (double-float "DBL" ,#'eql ,#'serialize-double ,+!lisp-double-float+) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Thu Jul 8 18:50:02 2010 @@ -112,7 +112,7 @@ (define-class-name +lisp-symbol+ "org.armedbear.lisp.Symbol") (define-class-name +lisp-thread+ "org.armedbear.lisp.LispThread") (define-class-name +lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding") -(define-class-name +!lisp-integer+ "org.armedbear.lisp.LispInteger") +(define-class-name +lisp-integer+ "org.armedbear.lisp.LispInteger") (define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum") (define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum") (define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat") From ehuelsmann at common-lisp.net Fri Jul 9 21:01:32 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 09 Jul 2010 17:01:32 -0400 Subject: [armedbear-cvs] r12796 - in branches/generic-class-file/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jul 9 17:01:30 2010 New Revision: 12796 Log: Merge trunk/abcl:r12762-r12795. Note: This branch will probably live for a while; keeping as close to trunk as possible for easier merge-back later on. Modified: branches/generic-class-file/abcl/doc/asdf/asdf.texinfo branches/generic-class-file/abcl/src/org/armedbear/lisp/Autoload.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java branches/generic-class-file/abcl/src/org/armedbear/lisp/JProxy.java branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: branches/generic-class-file/abcl/doc/asdf/asdf.texinfo ============================================================================== --- branches/generic-class-file/abcl/doc/asdf/asdf.texinfo (original) +++ branches/generic-class-file/abcl/doc/asdf/asdf.texinfo Fri Jul 9 17:01:30 2010 @@ -170,11 +170,9 @@ the ASDF internals and how to extend ASDF. @emph{Nota Bene}: -We are preparing for a release of ASDF 2, hopefully for May 2010, -which will have version 2.000 and later. -Current releases, in the 1.700 series and beyond, -should be considered as release candidates. -We're still working on polishing the code and documentation. +We have released ASDF 2.000 on May 31st 2010. +It hopefully will have been it included +in all CL maintained implementations shortly afterwards. @xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. @@ -241,7 +239,7 @@ then you're using an old version of ASDF (from before 1.635). If it returns @code{NIL} then ASDF is not installed. -If you are running a version older than 1.711, +If you are running a version older than 2.000, we recommend that you load a newer ASDF using the method below. @@ -340,27 +338,28 @@ the authors of that tool should already have configured ASDF. The simplest way to add a path to your search path, -say @file{/foo/bar/baz/quux/} +say @file{/home/luser/.asd-link-farm/} is to create the directory @file{~/.config/common-lisp/source-registry.conf.d/} -and there create a file with any name of your choice, -for instance @file{42-bazquux.conf} +and there create a file with any name of your choice but the type @file{conf}, +for instance @file{42-asd-link-farm.conf} containing the line: - at kbd{(:directory "/foo/bar/baz/quux/")} + at kbd{(:directory "/home/luser/.asd-link-farm/")} -If you want all the subdirectories under @file{/foo/bar/baz/} +If you want all the subdirectories under @file{/home/luser/lisp/} to be recursively scanned for @file{.asd} files, instead use: - at kbd{(:tree "/foo/bar/baz/quux/")} + at kbd{(:tree "/home/luser/lisp/")} Note that your Operating System distribution or your system administrator may already have configured system-managed libraries for you. -Also note that when choosing a filename, the convention is to use -the @file{.conf} extension -(and a non-empty extension is required for CLISP compatibility), -and it is customary to start the filename with two digits +The required @file{.conf} extension allows you to have disabled files +or editor backups (ending in @file{~}), and works portably +(for instance, it is a pain to allow both empty and non-empty extension on CLISP). +Excluded are files the name of which start with a @file{.} character. +It is customary to start the filename with two digits that specify the order in which the directories will be scanned. ASDF will automatically read your configuration @@ -485,7 +484,7 @@ to @file{/where/i/want/my/fasls/} is to create the directory @file{~/.config/common-lisp/asdf-output-translations.conf.d/} -and there create a file with any name of your choice, +and there create a file with any name of your choice and the type @file{conf}, for instance @file{42-bazquux.conf} containing the line: @@ -510,11 +509,11 @@ under an implementation-dependent subdirectory of @file{~/.cache/common-lisp/}. @xref{Controlling where ASDF searches for systems}, for full details. - -Also note that when choosing a filename, the convention is to use -the @file{.conf} extension -(and a non-empty extension is required for CLISP compatibility), -and it is customary to start the filename with two digits +The required @file{.conf} extension allows you to have disabled files +or editor backups (ending in @file{~}), and works portably +(for instance, it is a pain to allow both empty and non-empty extension on CLISP). +Excluded are files the name of which start with a @file{.} character. +It is customary to start the filename with two digits that specify the order in which the directories will be scanned. ASDF will automatically read your configuration @@ -535,7 +534,7 @@ each in subtly different and incompatible ways: ASDF-Binary-Locations, cl-launch, common-lisp-controller. ASDF-Binary-Locations is now not needed anymore and should not be used. -cl-launch 2.900 and common-lisp-controller 7.1 have been updated +cl-launch 3.000 and common-lisp-controller 7.2 have been updated to just delegate this functionality to ASDF. @node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top @@ -813,6 +812,7 @@ @code{:my-component-type}, or @code{my-component-type}. @subsection Pathname specifiers + at cindex pathname specifiers A pathname specifier (@code{pathname-specifier}) may be a pathname, a string or a symbol. @@ -845,6 +845,14 @@ and a string @code{"foo/bar.quux"} will be interpreted as the pathname @file{#p"foo/bar.quux"}. +ASDF does not interpret the string @code{".."} to designate the parent +directory. This string will be passed through to the underlying +operating system for interpretation. We @emph{believe} that this will +work on all platforms where ASDF is deployed, but do not guarantee this +behavior. A pathname object with a relative directory component of + at code{:up} or @code{:back} is the only guaranteed way to specify a +parent directory. + If a symbol is given, it will be translated into a string, and downcased in the process. The downcasing of symbols is unconventional, @@ -856,23 +864,26 @@ as argument to @code{make-pathname}, which is reported not to work on some implementations. -Pathnames objects may be given to override the path for a component. +Pathname objects may be given to override the path for a component. Such objects are typically specified using reader macros such as @code{#p} or @code{#.(make-pathname ...)}. -Note however, that @code{#p...} is a short for @code{#.(parse-namestring ...)} -and that the behavior @code{parse-namestring} is completely non-portable, -unless you are using Common Lisp @code{logical-pathname}s. -(@xref{The defsystem grammar,,Warning about logical pathnames}, below.) +Note however, that @code{#p...} is a shorthand for @code{#.(parse-namestring ...)} +and that the behavior of @code{parse-namestring} is completely non-portable, +unless you are using Common Lisp @code{logical-pathname}s +(@pxref{The defsystem grammar,,Warning about logical pathnames}, below). Pathnames made with @code{#.(make-pathname ...)} can usually be done more easily with the string syntax above. The only case that you really need a pathname object is to override the component-type default file type for a given component. -Therefore, it is a rare case that pathname objects should be used at all. +Therefore, pathname objects should only rarely be used. Unhappily, ASDF 1 didn't properly support parsing component names as strings specifying paths with directories, and the cumbersome @code{#.(make-pathname ...)} syntax had to be used. -Note that when specifying pathname objects, no magic interpretation of the pathname -is made depending on the component type. + +Note that when specifying pathname objects, +ASDF does not do any special interpretation of the pathname +influenced by the component type, unlike the procedure for +pathname-specifying strings. On the one hand, you have to be careful to provide a pathname that correctly fulfills whatever constraints are required from that component type (e.g. naming a directory or a file with appropriate type); @@ -881,6 +892,11 @@ @subsection Warning about logical pathnames + at cindex logical pathnames + +We recommend that you not use logical pathnames +in your asdf system definitions at this point, +but logical pathnames @emph{are} supported. To use logical pathnames, you will have to provide a pathname object as a @code{:pathname} specifier @@ -888,24 +904,29 @@ @code{#p"LOGICAL-HOST:absolute;path;to;component.lisp"}. You only have to specify such logical pathname for your system or -some top-level component, as sub-components using the usual string syntax -for names will be properly merged with the pathname of their parent. +some top-level component. Sub-components' relative pathnames, specified +using the string syntax +for names, will be properly merged with the pathnames of their parents. The specification of a logical pathname host however is @emph{not} otherwise directly supported in the ASDF syntax for pathname specifiers as strings. -Logical pathnames are not specifically recommended to newcomers, -but are otherwise supported. -Moreover, the @code{asdf-output-translation} layer will -avoid trying to resolve and translate logical-pathnames, -so you can define yourself what translations you want to use +The @code{asdf-output-translation} layer will +avoid trying to resolve and translate logical-pathnames. +The advantage of this is that you can define yourself what translations you want to use with the logical pathname facility. - -The user of logical pathnames will have to configure logical pathnames himself, -before they may be used, and ASDF provides no specific support for that. +The disadvantage is that if you do not define such translations, any +system that uses logical pathnames will be have differently under +asdf-output-translations than other systems you use. + +If you wish to use logical pathnames you will have to configure the +translations yourself before they may be used. +ASDF currently provides no specific support +for defining logical pathname translations. @subsection Serial dependencies + at cindex serial dependencies If the @code{:serial t} option is specified for a module, ASDF will add dependencies for each each child component, @@ -913,8 +934,8 @@ This is done as if by @code{:depends-on}. @lisp -:components ((:file "a") (:file "b") (:file "c")) :serial t +:components ((:file "a") (:file "b") (:file "c")) @end lisp is equivalent to @@ -1713,23 +1734,26 @@ ;; A directive is one of the following: DIRECTIVE := + ;; INHERITANCE DIRECTIVE: + ;; Your configuration expression MUST contain + ;; exactly one of either of these: + :inherit-configuration | ; splices inherited configuration (often specified last) + :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere) + ;; add a single directory to be scanned (no recursion) (:directory DIRECTORY-PATHNAME-DESIGNATOR) | ;; add a directory hierarchy, recursing but excluding specified patterns (:tree DIRECTORY-PATHNAME-DESIGNATOR) | - ;; override the default defaults for exclusion patterns + ;; override the defaults for exclusion patterns (:exclude PATTERN ...) | + ;; augment the defaults for exclusion patterns + (:also-exclude PATTERN ...) | ;; splice the parsed contents of another config file (:include REGULAR-FILE-PATHNAME-DESIGNATOR) | - ;; Your configuration expression MUST contain - ;; exactly one of either of these: - :inherit-configuration | ; splices contents of inherited configuration - :ignore-inherited-configuration | ; drop contents of inherited configuration - ;; This directive specifies that some default must be spliced. :default-registry @@ -1738,6 +1762,15 @@ of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"} @end example +For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf}, +which is the default place ASDF looks for this configuration, +once contained: + at example +(:source-registry + (:tree "/home/fare/cl/") + :inherit-configuration) + at end example + @section Configuration Directories @@ -1746,7 +1779,7 @@ The files will be sorted by namestring as if by @code{string<} and the lists of directives of these files with be concatenated in order. An implicit @code{:inherit-configuration} will be included -at the end of the list. +at the @emph{end} of the list. This allows for packaging software that has file granularity (e.g. Debian's @code{dpkg} or some future version of @code{clbuild}) @@ -1766,6 +1799,15 @@ (:include "/foo/bar/") @end example +Hence, to achieve the same effect as +my example @file{~/.config/common-lisp/source-registry.conf} above, +I could simply create a file + at file{~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf} +alone in its directory with the following contents: + at example +(:tree "/home/fare/cl/") + at end example + @section Shell-friendly syntax for configuration @@ -1808,9 +1850,14 @@ XCVB currently raised an error. If none is found, the search continues. -Exclude statements specify patterns of subdirectories the systems of which -to ignore. Typically you don't want to use copies of files kept by such +Exclude statements specify patterns of subdirectories +the systems from which to ignore. +Typically you don't want to use copies of files kept by such version control systems as Darcs. +Exclude statements are not propagated to further included or inherited +configuration files or expressions; +instead the defaults are reset around every configuration statement +to the default defaults from @code{asdf::*default-source-registry-exclusions*}. Include statements cause the search to recurse with the path specifications from the file specified. @@ -2057,7 +2104,7 @@ in an easy way with configuration files. Recent versions of same packages use the new @code{asdf-output-translations} API as defined below: - at code{common-lisp-controller} (7.1) and @code{cl-launch} (3.00); + at code{common-lisp-controller} (7.2) and @code{cl-launch} (3.000). @code{ASDF-Binary-Locations} is fully superseded and not to be used anymore. This incompatibility shouldn't inconvenience many people. @@ -2110,13 +2157,14 @@ ;; A directive is one of the following: DIRECTIVE := - ;; include a configuration file or directory - (:include PATHNAME-DESIGNATOR) | - + ;; INHERITANCE DIRECTIVE: ;; Your configuration expression MUST contain ;; exactly one of either of these: - :inherit-configuration | ; splices contents of inherited configuration - :ignore-inherited-configuration | ; drop contents of inherited configuration + :inherit-configuration | ; splices inherited configuration (often specified last) + :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere) + + ;; include a configuration file or directory + (:include PATHNAME-DESIGNATOR) | ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something. :enable-user-cache | @@ -2232,7 +2280,7 @@ The files will be sorted by namestring as if by @code{string<} and the lists of directives of these files with be concatenated in order. An implicit @code{:inherit-configuration} will be included -at the end of the list. +at the @emph{end} of the list. This allows for packaging software that has file granularity (e.g. Debian's @command{dpkg} or some future version of @command{clbuild}) @@ -2494,26 +2542,21 @@ @subsection What are ASDF 1 and ASDF 2? -We are preparing for a release of ASDF 2, -which will have version 2.000 and later. -While the code and documentation are essentially complete -we are still working on polishing them before release. - -Releases in the 1.700 series and beyond -should be considered as release candidates. -For all practical purposes, -ASDF 2 refers to releases later than 1.656, -and ASDF 1 to any release earlier than 1.369 or so. -If your ASDF doesn't have a version, it's old. +On May 31st 2010, we have released ASDF 2. +ASDF 2 refers to release 2.000 and later. +(Releases between 1.656 and 1.728 were development releases for ASDF 2.) +ASDF 1 to any release earlier than 1.369 or so. +If your ASDF doesn't sport a version, it's an old ASDF 1. -ASDF 2 release candidates and beyond will have +ASDF 2 and its release candidates push @code{:asdf2} onto @code{*features*} so that if you are writing ASDF-dependent code you may check for this feature to see if the new API is present. @emph{All} versions of ASDF should have the @code{:asdf} feature. If you are experiencing problems or limitations of any sort with ASDF 1, -we recommend that you should upgrade to ASDF 2 or its latest release candidate. +we recommend that you should upgrade to ASDF 2, +or whatever is the latest release. @subsection ASDF can portably name files in subdirectories @@ -2537,6 +2580,12 @@ @code{asdf-utilities:merge-pathnames*}, @code{asdf::merge-component-name-type}. +On the other hand, there are places where systems used to accept namestrings +where you must now use an explicit pathname object: + at code{(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} +must now be written with the @code{#p} syntax: + at code{(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} + @xref{The defsystem grammar,,Pathname specifiers}. @@ -2635,11 +2684,12 @@ @item The internal test suite used to massively fail on many implementations. While still incomplete, it now fully passes -on all implementations supported by the test suite. +on all implementations supported by the test suite, +except for GCL (due to GCL bugs). @item Support was lacking for some implementations. -ABCL was notably wholly broken. +ABCL and GCL were notably wholly broken. ECL extensions were not integrated in the ASDF release. @item @@ -2660,7 +2710,7 @@ With ASDF 2, we provide a new stable set of working features that everyone can rely on from now on. Use @code{#+asdf2} to detect presence of ASDF 2, - at code{(asdf:version-satisfies (asdf:asdf-version) "1.711")} + at code{(asdf:version-satisfies (asdf:asdf-version) "2.000")} to check the availability of a version no earlier than required. @@ -2733,6 +2783,16 @@ @pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. But thou shall not load ABL on top of ASDF 2. + at item +ASDF pathname designators are now specified in places where they were unspecified, +and a few small adjustments have to be made to some non-portable defsystems. +Notably, in the @code{:pathname} argument to a @code{defsystem} and its components, +a logical pathname (or implementation-dependent hierarchical pathname) +must now be specified with @code{#p} syntax +where the namestring might have previously sufficed; +moreover when evaluation is desired @code{#.} must be used, +where it wasn't necessary in the toplevel @code{:pathname} argument. + @end itemize Other issues include the following: @@ -3089,12 +3149,8 @@ @section Missing bits in implementation -** all of the above - ** reuse the same scratch package whenever a system is reloaded from disk -** rules for system pathname defaulting are not yet implemented properly - ** proclamations probably aren't ** when a system is reloaded with fewer components than it previously had, odd things happen @@ -3103,16 +3159,6 @@ like take the list of kids and @code{setf} the slot to @code{nil}, then transfer children from old to new list as they're found. -** traverse may become a normal function - -If you're defining methods on @code{traverse}, speak up. - - -** a lot of load-op methods can be rewritten to use input-files - -so should be. - - ** (stuff that might happen later) *** Propagation of the @code{:force} option. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Autoload.java Fri Jul 9 17:01:30 2010 @@ -514,6 +514,9 @@ 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_JAVA, "make-classloader", "JavaClassLoader"); + autoload(PACKAGE_JAVA, "add-to-classpath", "JavaClassLoader"); + autoload(PACKAGE_JAVA, "dump-classpath", "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: branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java Fri Jul 9 17:01:30 2010 @@ -40,11 +40,20 @@ private LispObject propertyList = NIL; private int callCount; private int hotCount; - - protected Function() {} + /** + * The value of *load-truename* which was current when this function + * was loaded, used for fetching the class bytes in case of disassebly. + */ + private final LispObject loadedFrom; + + protected Function() { + LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValueNoThrow(); + loadedFrom = loadTruename != null ? loadTruename : NIL; + } public Function(String name) { + this(); if (name != null) { Symbol symbol = Symbol.addFunction(name.toUpperCase(), this); if (cold) @@ -55,6 +64,7 @@ public Function(Symbol symbol, String arglist) { + this(); symbol.setSymbolFunction(this); if (cold) symbol.setBuiltInFunction(true); @@ -64,6 +74,7 @@ public Function(Symbol symbol, String arglist, String docstring) { + this(); symbol.setSymbolFunction(this); if (cold) symbol.setBuiltInFunction(true); @@ -100,6 +111,7 @@ public Function(String name, Package pkg, boolean exported, String arglist, String docstring) { + this(); if (arglist instanceof String) setLambdaList(new SimpleString(arglist)); if (name != null) { @@ -120,11 +132,13 @@ public Function(LispObject name) { + this(); setLambdaName(name); } public Function(LispObject name, LispObject lambdaList) { + this(); setLambdaName(name); setLambdaList(lambdaList); } @@ -182,7 +196,22 @@ } else { ClassLoader c = getClass().getClassLoader(); if(c instanceof FaslClassLoader) { - return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this)); + final LispThread thread = LispThread.currentThread(); + SpecialBindingsMark mark = thread.markSpecialBindings(); + try { + thread.bindSpecial(Symbol.LOAD_TRUENAME, loadedFrom); + return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this)); + } catch(Throwable t) { + //This is because unfortunately getFunctionClassBytes uses + //Debug.assertTrue(false) to signal errors + if(t instanceof ControlTransfer) { + throw (ControlTransfer) t; + } else { + return NIL; + } + } finally { + thread.resetSpecialBindings(mark); + } } else { return NIL; } Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/JProxy.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/JProxy.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/JProxy.java Fri Jul 9 17:01:30 2010 @@ -210,26 +210,26 @@ private static final Primitive _JMAKE_PROXY = new Primitive("%jmake-proxy", PACKAGE_JAVA, false, - "interface invocation-handler") { + "interfaces invocation-handler") { public LispObject execute(final LispObject[] args) { int length = args.length; if (length != 3) { return error(new WrongNumberOfArgumentsException(this)); } - if(!(args[0] instanceof JavaObject) || - !(((JavaObject) args[0]).javaInstance() instanceof Class)) { - return error(new TypeError(args[0], new SimpleString(Class.class.getName()))); + if(!(args[0] instanceof Cons)) { + return error(new TypeError(args[0], new SimpleString("CONS"))); } - if(!(args[1] instanceof JavaObject) || - !(((JavaObject) args[1]).javaInstance() instanceof InvocationHandler)) { - return error(new TypeError(args[1], new SimpleString(InvocationHandler.class.getName()))); - } - Class iface = (Class) ((JavaObject) args[0]).javaInstance(); - InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance(); + Class[] ifaces = new Class[args[0].length()]; + LispObject ifList = args[0]; + for(int i = 0; i < ifaces.length; i++) { + ifaces[i] = (Class) ifList.car().javaInstance(Class.class); + ifList = ifList.cdr(); + } + InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance(InvocationHandler.class); Object proxy = Proxy.newProxyInstance( - iface.getClassLoader(), - new Class[] { iface }, + JavaClassLoader.getCurrentClassLoader(), + ifaces, invocationHandler); synchronized(proxyMap) { proxyMap.put(proxy, args[2]); Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java Fri Jul 9 17:01:30 2010 @@ -39,8 +39,9 @@ import java.util.HashSet; import java.util.Set; import java.net.URL; +import java.net.URLClassLoader; -public class JavaClassLoader extends java.net.URLClassLoader { +public class JavaClassLoader extends URLClassLoader { private static JavaClassLoader persistentInstance; @@ -168,6 +169,92 @@ } }; + private static final Primitive DUMP_CLASSPATH = new pf_dump_classpath(); + private static final class pf_dump_classpath extends Primitive + { + pf_dump_classpath() + { + super("dump-classpath", PACKAGE_JAVA, true, "&optional classloader"); + } + + @Override + public LispObject execute() { + return execute(new JavaObject(getCurrentClassLoader())); + } + + @Override + public LispObject execute(LispObject classloader) { + LispObject list = NIL; + Object o = classloader.javaInstance(); + while(o instanceof ClassLoader) { + ClassLoader cl = (ClassLoader) o; + list = list.push(dumpClassPath(cl)); + o = cl.getParent(); + } + return list.nreverse(); + } + }; + + private static final Primitive ADD_TO_CLASSPATH = new pf_add_to_classpath(); + private static final class pf_add_to_classpath extends Primitive + { + pf_add_to_classpath() + { + super("add-to-classpath", PACKAGE_JAVA, true, "jar-or-jars &optional (classloader (get-current-classloader))"); + } + + @Override + public LispObject execute(LispObject jarOrJars) { + return execute(jarOrJars, new JavaObject(getCurrentClassLoader())); + } + + @Override + public LispObject execute(LispObject jarOrJars, LispObject classloader) { + Object o = classloader.javaInstance(); + if(o instanceof JavaClassLoader) { + JavaClassLoader jcl = (JavaClassLoader) o; + if(jarOrJars instanceof Cons) { + while(jarOrJars != NIL) { + addURL(jcl, jarOrJars.car()); + jarOrJars = jarOrJars.cdr(); + } + } else { + addURL(jcl, jarOrJars); + } + return T; + } else { + return error(new TypeError(o + " must be an instance of " + JavaClassLoader.class.getName())); + } + } + }; + + protected static void addURL(JavaClassLoader jcl, LispObject jar) { + try { + if(jar instanceof Pathname) { + jcl.addURL(((Pathname) jar).toURL()); + } else if(jar instanceof AbstractString) { + jcl.addURL(new Pathname(jar.toString()).toURL()); + } else { + error(new TypeError(jar + " must be a pathname designator")); + } + } catch(java.net.MalformedURLException e) { + error(new LispError(jar + " is not a valid URL")); + } + } + + + public static LispObject dumpClassPath(ClassLoader o) { + if(o instanceof URLClassLoader) { + LispObject list = NIL; + for(URL u : ((URLClassLoader) o).getURLs()) { + list = list.push(new Pathname(u)); + } + return new Cons(new JavaObject(o), list.nreverse()); + } else { + return new JavaObject(o); + } + } + public static ClassLoader getCurrentClassLoader() { LispObject classLoader = CLASSLOADER.symbolValueNoThrow(); if(classLoader != null) { Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java Fri Jul 9 17:01:30 2010 @@ -606,8 +606,8 @@ // the namestring." 19.2.2.2.3.1 if (host != NIL) { Debug.assertTrue(host instanceof AbstractString - || host instanceof Cons); - if (host instanceof Cons) { + || isURL()); + if (isURL()) { LispObject scheme = Symbol.GETF.execute(host, SCHEME, NIL); LispObject authority = Symbol.GETF.execute(host, AUTHORITY, NIL); Debug.assertTrue(scheme != NIL); @@ -631,7 +631,7 @@ } if (device == NIL) { } else if (device == Keyword.UNSPECIFIC) { - } else if (device instanceof Cons) { + } else if (isJar()) { LispObject[] jars = ((Cons) device).copyToArray(); StringBuilder prefix = new StringBuilder(); for (int i = 0; i < jars.length; i++) { @@ -643,9 +643,6 @@ sb.append("!/"); } sb = prefix.append(sb); - } else if (device instanceof AbstractString - && device.getStringValue().startsWith("jar:")) { - sb.append(device.getStringValue()); } else if (device instanceof AbstractString) { sb.append(device.getStringValue()); if (this instanceof LogicalPathname @@ -723,7 +720,7 @@ } } namestring = sb.toString(); - // XXX Decide when this is necessary + // XXX Decide if this is necessary // if (isURL()) { // namestring = Utilities.uriEncode(namestring); // } @@ -1236,7 +1233,7 @@ namestring = file.getCanonicalPath(); } catch (IOException e) { Debug.trace("Failed to make a Pathname from " - + "." + file + "'"); + + "'" + file + "'"); return null; } return new Pathname(namestring); @@ -1290,7 +1287,7 @@ if (host == NIL) { host = defaults.host; } - if (directory == NIL && defaults != null) { + if (directory == NIL) { directory = defaults.directory; } if (!deviceSupplied) { @@ -2084,7 +2081,8 @@ if (pathname.isURL()) { result = new URL(pathname.getNamestring()); } else { - // XXX ensure that we have cannonical path. + // XXX Properly encode Windows drive letters and UNC paths + // XXX ensure that we have cannonical path? result = new URL("file://" + pathname.getNamestring()); } } catch (MalformedURLException e) { @@ -2342,6 +2340,22 @@ return getNamestring(); } + public URL toURL() throws MalformedURLException { + if(isURL()) { + return new URL(getNamestring()); + } else { + return toFile().toURL(); + } + } + + public File toFile() { + if(!isURL()) { + return new File(getNamestring()); + } else { + throw new RuntimeException(this + " does not represent a file"); + } + } + static { LispObject obj = Symbol.DEFAULT_PATHNAME_DEFAULTS.getSymbolValue(); Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(coerceToPathname(obj)); Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java Fri Jul 9 17:01:30 2010 @@ -523,8 +523,10 @@ // If we're looking at zero return values, set 'value' to null if (value == NIL) { LispObject[] values = thread._values; - if (values != null && values.length == 0) + if (values != null && values.length == 0) { value = null; + thread._values = null; // reset 'no values' indicator + } } return value; } Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp Fri Jul 9 17:01:30 2010 @@ -47,30 +47,30 @@ #+xcvb (module ()) -(cl:in-package :cl-user) +(cl:in-package :cl) +(defpackage :asdf-bootstrap (:use :cl)) +(in-package :asdf-bootstrap) -(declaim (optimize (speed 2) (debug 2) (safety 3)) - #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) - -#+ecl (require :cmp) +;; Implementation-dependent tweaks +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults. + #+allegro + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) + #+ecl (require :cmp) + #+gcl + (eval-when (:compile-toplevel :load-toplevel) + (defpackage :asdf-utilities (:use :cl)) + (defpackage :asdf (:use :cl :asdf-utilities)))) ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more at the end of the file. -#+gcl -(eval-when (:compile-toplevel :load-toplevel) - (defpackage :asdf-utilities (:use :cl)) - (defpackage :asdf (:use :cl :asdf-utilities))) - (eval-when (:load-toplevel :compile-toplevel :execute) - #+allegro - (setf excl::*autoload-package-name-alist* - (remove "asdf" excl::*autoload-package-name-alist* - :test 'equalp :key 'car)) - (let* ((asdf-version - ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:1.719" (1+ (length "VERSION")))) + (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate + (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105. (existing-asdf (find-package :asdf)) (vername '#:*asdf-version*) (versym (and existing-asdf @@ -80,7 +80,7 @@ (unless (and existing-asdf already-there) #-gcl (when existing-asdf - (format *error-output* + (format *trace-output* "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" existing-version asdf-version)) (labels @@ -155,13 +155,11 @@ (macrolet ((pkgdcl (name &key nicknames use export redefined-functions unintern fmakunbound shadow) - `(ensure-package - ',name :nicknames ',nicknames :use ',use :export ',export - :shadow ',shadow - :unintern ',(append #-(or gcl ecl) redefined-functions - unintern) - :fmakunbound ',(append #+(or gcl ecl) redefined-functions - fmakunbound)))) + `(ensure-package + ',name :nicknames ',nicknames :use ',use :export ',export + :shadow ',shadow + :unintern ',(append #-(or gcl ecl) redefined-functions unintern) + :fmakunbound ',(append fmakunbound)))) (pkgdcl :asdf-utilities :nicknames (#:asdf-extensions) @@ -290,6 +288,7 @@ #:clear-output-translations #:ensure-output-translations #:apply-output-translations + #:compile-file* #:compile-file-pathname* #:enable-asdf-binary-locations-compatibility @@ -327,6 +326,7 @@ '(defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key) (declare (ignorable deleted plist)) + (format *trace-output* "Updating ~A~%" m) (when (member 'components-by-name added) (compute-module-components-by-name m)))))) @@ -336,7 +336,7 @@ (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. You can compare this string with e.g.: -(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")." +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")." *asdf-version*) (defvar *resolve-symlinks* t @@ -344,9 +344,15 @@ Defaults to `t`.") -(defvar *compile-file-warnings-behaviour* :warn) - -(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) +(defvar *compile-file-warnings-behaviour* :warn + "How should ASDF react if it encounters a warning when compiling a +file? Valid values are :error, :warn, and :ignore.") + +(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn + "How should ASDF react if it encounters a failure \(per the +ANSI spec of COMPILE-FILE\) when compiling a file? Valid values are +:error, :warn, and :ignore. Note that ASDF ALWAYS raises an error +if it fails to create an output file when compiling.") (defvar *verbose-out* nil) @@ -365,16 +371,20 @@ ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. - -(defgeneric perform-with-restarts (operation component)) -(defgeneric perform (operation component)) -(defgeneric operation-done-p (operation component)) -(defgeneric explain (operation component)) -(defgeneric output-files (operation component)) -(defgeneric input-files (operation component)) +(defmacro defgeneric* (name formals &rest options) + `(progn + #+(or gcl ecl) (fmakunbound ',name) + (defgeneric ,name ,formals , at options))) + +(defgeneric* perform-with-restarts (operation component)) +(defgeneric* perform (operation component)) +(defgeneric* operation-done-p (operation component)) +(defgeneric* explain (operation component)) +(defgeneric* output-files (operation component)) +(defgeneric* input-files (operation component)) (defgeneric component-operation-time (operation component)) -(defgeneric system-source-file (system) +(defgeneric* system-source-file (system) (:documentation "Return the source file in which system is defined.")) (defgeneric component-system (component) @@ -396,7 +406,7 @@ (defgeneric version-satisfies (component version)) -(defgeneric find-component (base path) +(defgeneric* find-component (base path) (:documentation "Finds the component with PATH starting from BASE module; if BASE is nil, then the component is assumed to be a system.")) @@ -455,17 +465,27 @@ (defgeneric traverse (operation component) (:documentation -"Generate and return a plan for performing `operation` on `component`. +"Generate and return a plan for performing OPERATION on COMPONENT. -The plan returned is a list of dotted-pairs. Each pair is the `cons` -of ASDF operation object and a `component` object. The pairs will be -processed in order by `operate`.")) +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities (defmacro while-collecting ((&rest collectors) &body body) + "COLLECTORS should be a list of names for collections. A collector +defines a function that, when applied to an argument inside BODY, will +add its argument to the corresponding collection. Returns multiple values, +a list for each collection, in order. + E.g., +\(while-collecting \(foo bar\) + \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) + \(foo \(first x\)\) + \(bar \(second x\)\)\)\) +Returns two values: \(A B C\) and \(1 2 3\)." (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) (initial-values (mapcar (constantly nil) collectors))) `(let ,(mapcar #'list vars initial-values) @@ -479,10 +499,8 @@ (defun pathname-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME, TYPE and VERSION components" - (make-pathname :name nil :type nil :version nil :defaults pathname)) - -(defun current-directory () - (truenamize (pathname-directory-pathname *default-pathname-defaults*))) + (when pathname + (make-pathname :name nil :type nil :version nil :defaults pathname))) (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname @@ -493,7 +511,7 @@ (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) - (directory (if (stringp directory) `(:absolute ,directory) directory)) + #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory)) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) @@ -516,9 +534,9 @@ ((:relative) (values (pathname-host defaults) (pathname-device defaults) - (if (null (pathname-directory defaults)) - directory - (append (pathname-directory defaults) (cdr directory))) + (if (pathname-directory defaults) + (append (pathname-directory defaults) (cdr directory)) + directory) (unspecific-handler defaults))) #+gcl (t @@ -538,13 +556,19 @@ (define-modify-macro orf (&rest args) or "or a flag") +(defun first-char (s) + (and (stringp s) (plusp (length s)) (char s 0))) + +(defun last-char (s) + (and (stringp s) (plusp (length s)) (char s (1- (length s))))) + (defun asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) (apply #'format *verbose-out* format-string format-args)) (defun split-string (string &key max (separator '(#\Space #\Tab))) - "Split STRING in components separater by any of the characters in the sequence SEPARATOR, -return a list. + "Split STRING into a list of components separated by +any of the characters in the sequence SEPARATOR. If MAX is specified, then no more than max(1,MAX) components will be returned, starting the separation from the end, e.g. when called with arguments \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." @@ -595,13 +619,14 @@ (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") - (if (and (plusp (length s)) (eql (char s 0) #\/)) + (if (equal (first-char s) #\/) (values :absolute (cdr components)) (values :relative nil)) (values :relative components)) + (setf components (remove "" components :test #'equal)) (cond ((equal last-comp "") - (values relative (butlast components) nil)) + (values relative components nil)) ; "" already removed (force-directory (values relative components nil)) (t @@ -618,17 +643,13 @@ :unless (eq k key) :append (list k v))) -(defun resolve-symlinks (path) - #-allegro (truenamize path) - #+allegro (excl:pathname-resolve-symbolic-links path)) - (defun getenv (x) #+abcl (ext:getenv x) #+sbcl (sb-ext:posix-getenv x) #+clozure - (ccl::getenv x) + (ccl:getenv x) #+clisp (ext:getenv x) #+cmu @@ -643,13 +664,13 @@ (si:getenv x)) (defun directory-pathname-p (pathname) - "Does `pathname` represent a directory? + "Does PATHNAME represent a directory? A directory-pathname is a pathname _without_ a filename. The three -ways that the filename components can be missing are for it to be `nil`, -`:unspecific` or the empty string. +ways that the filename components can be missing are for it to be NIL, +:UNSPECIFIC or the empty string. -Note that this does _not_ check to see that `pathname` points to an +Note that this does _not_ check to see that PATHNAME points to an actually-existing directory." (flet ((check-one (x) (member x '(nil :unspecific "") :test 'equal))) @@ -733,10 +754,8 @@ (directory (pathname-directory p))) (when (typep p 'logical-pathname) (return p)) (ignore-errors (return (truename p))) - (when (stringp directory) - (return p)) - (when (not (eq :absolute (car directory))) - (return p)) + #-sbcl (when (stringp directory) (return p)) + (when (not (eq :absolute (car directory))) (return p)) (let ((sofar (ignore-errors (truename (pathname-root p))))) (unless sofar (return p)) (flet ((solution (directories) @@ -760,9 +779,43 @@ :finally (return (solution nil)))))))) +(defun resolve-symlinks (path) + #-allegro (truenamize path) + #+allegro (excl:pathname-resolve-symbolic-links path)) + +(defun default-directory () + (truenamize (pathname-directory-pathname *default-pathname-defaults*))) + (defun lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) +(defparameter *wild-path* + (make-pathname :directory '(:relative :wild-inferiors) + :name :wild :type :wild :version :wild)) + +(defun wilden (path) + (merge-pathnames* *wild-path* path)) + +(defun directorize-pathname-host-device (pathname) + (let* ((root (pathname-root pathname)) + (wild-root (wilden root)) + (absolute-pathname (merge-pathnames* pathname root)) + (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) + (separator (last-char (namestring foo))) + (root-namestring (namestring root)) + (root-string + (substitute-if #\/ + (lambda (x) (or (eql x #\:) + (eql x separator))) + root-namestring))) + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components root-string t) + (declare (ignore relative filename)) + (let ((new-base + (make-pathname :defaults root + :directory `(:absolute , at path)))) + (translate-pathname absolute-pathname wild-root (wilden new-base)))))) + ;;;; ------------------------------------------------------------------------- ;;;; Classes, Conditions @@ -775,6 +828,15 @@ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object)) +(declaim (ftype (function (t) t) + format-arguments format-control + error-name error-pathname error-condition + duplicate-names-name + error-component error-operation + module-components module-components-by-name) + (ftype (function (t t) t) (setf module-components-by-name))) + + (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) @@ -894,8 +956,8 @@ (defvar *default-component-class* 'cl-source-file) (defun compute-module-components-by-name (module) - (let ((hash (module-components-by-name module))) - (clrhash hash) + (let ((hash (make-hash-table :test 'equal))) + (setf (module-components-by-name module) hash) (loop :for c :in (module-components module) :for name = (component-name c) :for previous = (gethash name (module-components-by-name module)) @@ -911,7 +973,6 @@ :initarg :components :accessor module-components) (components-by-name - :initform (make-hash-table :test 'equal) :accessor module-components-by-name) ;; What to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing. @@ -939,7 +1000,7 @@ (let ((pathname (merge-pathnames* (component-relative-pathname component) - (component-parent-pathname component)))) + (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) (error "Invalid relative pathname ~S for component ~S" pathname component)) (setf (slot-value component 'absolute-pathname) pathname) @@ -1013,9 +1074,9 @@ (gethash (coerce-name name) *defined-systems*)) (defun map-systems (fn) - "Apply `fn` to each defined system. + "Apply FN to each defined system. -`fn` should be a function of one argument. It will be +FN should be a function of one argument. It will be called with an object of type asdf:system." (maphash (lambda (_ datum) (declare (ignore _)) @@ -1028,7 +1089,7 @@ ;;; convention that functions in this list are prefixed SYSDEF- (defparameter *system-definition-search-functions* - '(sysdef-central-registry-search sysdef-source-registry-search)) + '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) (defun system-definition-pathname (system) (let ((system-name (coerce-name system))) @@ -1054,6 +1115,27 @@ Going forward, we recommend new users should be using the source-registry. ") +(defun probe-asd (name defaults) + (block nil + (when (directory-pathname-p defaults) + (let ((file + (make-pathname + :defaults defaults :version :newest :case :local + :name name + :type "asd"))) + (when (probe-file file) + (return file))) + #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) + (let ((shortcut + (make-pathname + :defaults defaults :version :newest :case :local + :name (concatenate 'string name ".asd") + :type "lnk"))) + (when (probe-file shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target))))))))) + (defun sysdef-central-registry-search (system) (let ((name (coerce-name system)) (to-remove nil) @@ -1072,8 +1154,8 @@ (let* ((*print-circle* nil) (message (format nil - "~@" + "~@" system dir defaults))) (error message)) (remove-entry-from-registry () @@ -1122,37 +1204,50 @@ 0))) (defun find-system (name &optional (error-p t)) - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) - (on-disk (system-definition-pathname name))) - (when (and on-disk - (or (not in-memory) - (< (car in-memory) (safe-file-write-date on-disk)))) - (let ((package (make-temporary-package))) - (unwind-protect - (handler-bind - ((error (lambda (condition) - (error 'load-system-definition-error - :name name :pathname on-disk - :condition condition)))) - (let ((*package* package)) - (asdf-message - "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" - on-disk *package*) - (load on-disk))) - (delete-package package)))) - (let ((in-memory (system-registered-p name))) - (if in-memory - (progn (when on-disk (setf (car in-memory) - (safe-file-write-date on-disk))) - (cdr in-memory)) - (when error-p (error 'missing-component :requires name)))))) + (catch 'find-system + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (safe-file-write-date on-disk)))) + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error (lambda (condition) + (error 'load-system-definition-error + :name name :pathname on-disk + :condition condition)))) + (let ((*package* package)) + (asdf-message + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + on-disk *package*) + (load on-disk))) + (delete-package package)))) + (let ((in-memory (system-registered-p name))) + (if in-memory + (progn (when on-disk (setf (car in-memory) + (safe-file-write-date on-disk))) + (cdr in-memory)) + (when error-p (error 'missing-component :requires name))))))) (defun register-system (name system) (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) +(defun sysdef-find-asdf (system) + (let ((name (coerce-name system))) + (when (equal name "asdf") + (let* ((registered (cdr (gethash name *defined-systems*))) + (asdf (or registered + (make-instance + 'system :name "asdf" + :source-file (or *compile-file-truename* *load-truename*))))) + (unless registered + (register-system "asdf" asdf)) + (throw 'find-system asdf))))) + ;;;; ------------------------------------------------------------------------- ;;;; Finding components @@ -1171,8 +1266,9 @@ (find-component (car base) (cons (cdr base) path))) (defmethod find-component ((module module) (name string)) - (when (slot-boundp module 'components-by-name) - (values (gethash name (module-components-by-name module))))) + (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!! + (compute-module-components-by-name module)) + (values (gethash name (module-components-by-name module)))) (defmethod find-component ((component component) (name symbol)) (if name @@ -1602,19 +1698,6 @@ (visit-component operation c flag) flag)) -(defmethod traverse ((operation operation) (c component)) - ;; cerror'ing a feature that seems to have NEVER EVER worked - ;; ever since danb created it in his 2003-03-16 commit e0d02781. - ;; It was both fixed and disabled in the 1.700 rewrite. - (when (consp (operation-forced operation)) - (cerror "Continue nonetheless." - "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") - (setf (operation-forced operation) - (mapcar #'coerce-name (operation-forced operation)))) - (flatten-tree - (while-collecting (collect) - (do-traverse operation c #'collect)))) - (defun flatten-tree (l) ;; You collected things into a list. ;; Most elements are just things to collect again. @@ -1631,6 +1714,19 @@ (dolist (x l) (r x)))) (r* l)))) +(defmethod traverse ((operation operation) (c component)) + ;; cerror'ing a feature that seems to have NEVER EVER worked + ;; ever since danb created it in his 2003-03-16 commit e0d02781. + ;; It was both fixed and disabled in the 1.700 rewrite. + (when (consp (operation-forced operation)) + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") + (setf (operation-forced operation) + (mapcar #'coerce-name (operation-forced operation)))) + (flatten-tree + (while-collecting (collect) + (do-traverse operation c #'collect)))) + (defmethod perform ((operation operation) (c source-file)) (sysdef-error "~@" type)))) + (or (loop :for symbol :in (list + (unless (keywordp type) type) + (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) :asdf)) + :for class = (and symbol (find-class symbol nil)) + :when (and class (subtypep class 'component)) + :return class) + (and (eq type :file) + (or (module-default-component-class parent) + (find-class *default-component-class*))) + (sysdef-error "~@" type))) (defun maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. @@ -2178,9 +2271,9 @@ ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 (defun run-shell-command (control-string &rest args) - "Interpolate `args` into `control-string` as if by `format`, and + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with -output to `*verbose-out*`. Returns the shell's exit code." +output to *VERBOSE-OUT*. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) (asdf-message "; $ ~A~%" command) @@ -2333,7 +2426,7 @@ (when (member :lispworks-64bit *features*) "-64bit")) ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) - #+(or mcl sbcl scl) s + #+(or cormanlisp mcl sbcl scl) s #-(or allegro armedbear clisp clozure cmu cormanlisp digitool ecl gcl lispworks mcl sbcl scl) s)) @@ -2453,10 +2546,15 @@ (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) (funcall validator (car forms)))) +(defun hidden-file-p (pathname) + (equal (first-char (pathname-name pathname)) #\.)) + (defun validate-configuration-directory (directory tag validator) (let ((files (sort (ignore-errors - (directory (make-pathname :name :wild :type :wild :defaults directory) - #+sbcl :resolve-symlinks #+sbcl nil)) + (remove-if + 'hidden-file-p + (directory (make-pathname :name :wild :type "conf" :defaults directory) + #+sbcl :resolve-symlinks #+sbcl nil))) #'string< :key #'namestring))) `(,tag ,@(loop :for file :in files :append @@ -2513,16 +2611,38 @@ (setf *output-translations* '()) (values)) -(defparameter *wild-path* - (make-pathname :directory '(:relative :wild-inferiors) - :name :wild :type :wild :version :wild)) - (defparameter *wild-asd* (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type "asd" :version :newest)) -(defun wilden (path) - (merge-pathnames* *wild-path* path)) + +(declaim (ftype (function (t &optional boolean) (or null pathname)) + resolve-location)) + +(defun resolve-relative-location-component (super x &optional wildenp) + (let* ((r (etypecase x + (pathname x) + (string x) + (cons + (let ((car (resolve-relative-location-component super (car x) nil))) + (if (null (cdr x)) + car + (let ((cdr (resolve-relative-location-component + (merge-pathnames* car super) (cdr x) wildenp))) + (merge-pathnames* cdr car))))) + ((eql :default-directory) + (relativize-pathname-directory (default-directory))) + ((eql :implementation) (implementation-identifier)) + ((eql :implementation-type) (string-downcase (implementation-type))) + #-(and (or win32 windows mswindows mingw32) (not cygwin)) + ((eql :uid) (princ-to-string (get-uid))))) + (d (if (pathnamep x) r (ensure-directory-pathname r))) + (s (if (and wildenp (not (pathnamep x))) + (wilden d) + d))) + (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) + (error "pathname ~S is not relative to ~S" s super)) + (merge-pathnames* s super))) (defun resolve-absolute-location-component (x wildenp) (let* ((r @@ -2544,7 +2664,7 @@ ((eql :home) (user-homedir)) ((eql :user-cache) (resolve-location *user-cache* nil)) ((eql :system-cache) (resolve-location *system-cache* nil)) - ((eql :current-directory) (current-directory)))) + ((eql :default-directory) (default-directory)))) (s (if (and wildenp (not (pathnamep x))) (wilden r) r))) @@ -2552,30 +2672,6 @@ (error "Not an absolute pathname ~S" s)) s)) -(defun resolve-relative-location-component (super x &optional wildenp) - (let* ((r (etypecase x - (pathname x) - (string x) - (cons - (let ((car (resolve-relative-location-component super (car x) nil))) - (if (null (cdr x)) - car - (let ((cdr (resolve-relative-location-component - (merge-pathnames* car super) (cdr x) wildenp))) - (merge-pathnames* cdr car))))) - ((eql :current-directory) - (relativize-pathname-directory (current-directory))) - ((eql :implementation) (implementation-identifier)) - ((eql :implementation-type) (string-downcase (implementation-type))) - ((eql :uid) (princ-to-string (get-uid))))) - (d (if (pathnamep x) r (ensure-directory-pathname r))) - (s (if (and wildenp (not (pathnamep x))) - (wilden d) - d))) - (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) - (error "pathname ~S is not relative to ~S" s super)) - (merge-pathnames* s super))) - (defun resolve-location (x &optional wildenp) (if (atom x) (resolve-absolute-location-component x wildenp) @@ -2681,8 +2777,8 @@ ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. #+sbcl (,(getenv "SBCL_HOME") ()) - #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually. - #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system + #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system + #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: @@ -2706,6 +2802,11 @@ (getenv "ASDF_OUTPUT_TRANSLATIONS")) (defgeneric process-output-translations (spec &key inherit collect)) +(declaim (ftype (function (t &key (:collect (or symbol function))) t) + inherit-output-translations)) +(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t) + process-output-translations-directive)) + (defmethod process-output-translations ((x symbol) &key (inherit *default-output-translations*) collect) @@ -2833,29 +2934,6 @@ (translate-pathname p absolute-source destination))) :finally (return p))))) -(defun last-char (s) - (and (stringp s) (plusp (length s)) (char s (1- (length s))))) - -(defun directorize-pathname-host-device (pathname) - (let* ((root (pathname-root pathname)) - (wild-root (wilden root)) - (absolute-pathname (merge-pathnames* pathname root)) - (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) - (separator (last-char (namestring foo))) - (root-namestring (namestring root)) - (root-string - (substitute-if #\/ - (lambda (x) (or (eql x #\:) - (eql x separator))) - root-namestring))) - (multiple-value-bind (relative path filename) - (component-name-to-pathname-components root-string t) - (declare (ignore relative filename)) - (let ((new-base - (make-pathname :defaults root - :directory `(:absolute , at path)))) - (translate-pathname absolute-pathname wild-root (wilden new-base)))))) - (defmethod output-files :around (operation component) "Translate output files, unless asked not to" (declare (ignorable operation component)) @@ -2866,11 +2944,45 @@ (mapcar #'apply-output-translations files))) t)) -(defun compile-file-pathname* (input-file &rest keys) - (apply-output-translations - (apply #'compile-file-pathname - (truenamize (lispize-pathname input-file)) - keys))) +(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + (or output-file + (apply-output-translations + (apply 'compile-file-pathname + (truenamize (lispize-pathname input-file)) + keys)))) + +(defun tmpize-pathname (x) + (make-pathname + :name (format nil "ASDF-TMP-~A" (pathname-name x)) + :defaults x)) + +(defun delete-file-if-exists (x) + (when (probe-file x) + (delete-file x))) + +(defun compile-file* (input-file &rest keys &key &allow-other-keys) + (let* ((output-file (apply 'compile-file-pathname* input-file keys)) + (tmp-file (tmpize-pathname output-file)) + (status :error)) + (multiple-value-bind (output-truename warnings-p failure-p) + (apply 'compile-file input-file :output-file tmp-file keys) + (cond + (failure-p + (setf status *compile-file-failure-behaviour*)) + (warnings-p + (setf status *compile-file-warnings-behaviour*)) + (t + (setf status :success))) + (ecase status + ((:success :warn :ignore) + (delete-file-if-exists output-file) + (when output-truename + (rename-file output-truename output-file) + (setf output-truename output-file))) + (:error + (delete-file-if-exists output-truename) + (setf output-truename nil))) + (values output-truename warnings-p failure-p)))) #+abcl (defun translate-jar-pathname (source wildcard) @@ -2998,11 +3110,13 @@ ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 ;; Using ack 1.2 exclusions -(defvar *default-exclusions* +(defvar *default-source-registry-exclusions* '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build")) +(defvar *source-registry-exclusions* *default-source-registry-exclusions*) + (defvar *source-registry* () "Either NIL (for uninitialized), or a list of one element, said element itself being a list of directory pathnames where to look for .asd files") @@ -3024,34 +3138,6 @@ (setf *source-registry* '()) (values)) -(defun probe-asd (name defaults) - (block nil - (when (directory-pathname-p defaults) - (let ((file - (make-pathname - :defaults defaults :version :newest :case :local - :name name - :type "asd"))) - (when (probe-file file) - (return file))) - #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) - (let ((shortcut - (make-pathname - :defaults defaults :version :newest :case :local - :name (concatenate 'string name ".asd") - :type "lnk"))) - (when (probe-file shortcut) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target))))))))) - -(defun sysdef-source-registry-search (system) - (ensure-source-registry) - (loop :with name = (coerce-name system) - :for defaults :in (source-registry) - :for file = (probe-asd name defaults) - :when file :return file)) - (defun validate-source-registry-directive (directive) (unless (or (member directive '(:default-registry (:default-registry)) :test 'equal) @@ -3060,7 +3146,7 @@ ((:include :directory :tree) (and (length=n-p rest 1) (typep (car rest) '(or pathname string null)))) - ((:exclude) + ((:exclude :also-exclude) (every #'stringp rest)) (null rest)))) (error "Invalid directive ~S~%" directive)) @@ -3146,7 +3232,8 @@ (defun wrapping-source-registry () `(:source-registry #+sbcl (:tree ,(getenv "SBCL_HOME")) - :inherit-configuration)) + :inherit-configuration + #+cmu (:tree #p"modules:"))) (defun default-source-registry () (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(:source-registry @@ -3185,6 +3272,11 @@ (getenv "CL_SOURCE_REGISTRY")) (defgeneric process-source-registry (spec &key inherit register)) +(declaim (ftype (function (t &key (:register (or symbol function))) t) + inherit-source-registry)) +(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t) + process-source-registry-directive)) + (defmethod process-source-registry ((x symbol) &key inherit register) (process-source-registry (funcall x) :inherit inherit :register register)) (defmethod process-source-registry ((pathname pathname) &key inherit register) @@ -3204,7 +3296,7 @@ (declare (ignorable x)) (inherit-source-registry inherit :register register)) (defmethod process-source-registry ((form cons) &key inherit register) - (let ((*default-exclusions* *default-exclusions*)) + (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) (dolist (directive (cdr (validate-source-registry-form form))) (process-source-registry-directive directive :inherit inherit :register register)))) @@ -3225,15 +3317,18 @@ ((:tree) (destructuring-bind (pathname) rest (when pathname - (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*)))) + (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*)))) ((:exclude) - (setf *default-exclusions* rest)) + (setf *source-registry-exclusions* rest)) + ((:also-exclude) + (appendf *source-registry-exclusions* rest)) ((:default-registry) (inherit-source-registry '(default-source-registry) :register register)) ((:inherit-configuration) (inherit-source-registry inherit :register register)) ((:ignore-inherited-configuration) - nil)))) + nil))) + nil) (defun flatten-source-registry (&optional parameter) (remove-duplicates @@ -3268,6 +3363,13 @@ (source-registry) (initialize-source-registry))) +(defun sysdef-source-registry-search (system) + (ensure-source-registry) + (loop :with name = (coerce-name system) + :for defaults :in (source-registry) + :for file = (probe-asd name defaults) + :when file :return file)) + ;;;; ----------------------------------------------------------------- ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL ;;;; @@ -3278,16 +3380,16 @@ ((style-warning #'muffle-warning) (missing-component (constantly nil)) (error (lambda (e) - (format *error-output* "ASDF could not load ~A because ~A.~%" + (format *error-output* "ASDF could not load ~(~A~) because ~A.~%" name e)))) (let* ((*verbose-out* (make-broadcast-stream)) - (system (find-system name nil))) + (system (find-system (string-downcase name) nil))) (when system - (load-system name) + (load-system system) t)))) (pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* - #+clozure ccl::*module-provider-functions* + #+clozure ccl:*module-provider-functions* #+cmu ext:*module-provider-functions* #+ecl si:*module-provider-functions* #+sbcl sb-ext:*module-provider-functions*)) @@ -3312,7 +3414,7 @@ ;;;; ----------------------------------------------------------------- ;;;; Done! (when *load-verbose* - (asdf-message ";; ASDF, version ~a" (asdf-version))) + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) #+allegro (eval-when (:compile-toplevel :execute) @@ -3320,7 +3422,6 @@ (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) (pushnew :asdf *features*) -;; this is a release candidate for ASDF 2.0 (pushnew :asdf2 *features*) (provide :asdf) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp Fri Jul 9 17:01:30 2010 @@ -92,15 +92,21 @@ (fmakunbound 'jmake-proxy)) (defgeneric jmake-proxy (interface implementation &optional lisp-this) - (:documentation "Returns a proxy Java object implementing the provided interface using methods implemented in Lisp - typically closures, but implementations are free to provide other mechanisms. You can pass an optional 'lisp-this' object that will be passed to the implementing methods as their first argument. If you don't provide this object, NIL will be used. The second argument of the Lisp methods is the name of the Java method being implemented. This has the implication that overloaded methods are merged, so you have to manually discriminate them if you want to. The remaining arguments are java-objects wrapping the method's parameters.")) + (:documentation "Returns a proxy Java object implementing the provided interface(s) using methods implemented in Lisp - typically closures, but implementations are free to provide other mechanisms. You can pass an optional 'lisp-this' object that will be passed to the implementing methods as their first argument. If you don't provide this object, NIL will be used. The second argument of the Lisp methods is the name of the Java method being implemented. This has the implication that overloaded methods are merged, so you have to manually discriminate them if you want to. The remaining arguments are java-objects wrapping the method's parameters.")) + +(defun canonicalize-jproxy-interfaces (ifaces) + (if (listp ifaces) + (mapcar #'jclass ifaces) + (list (jclass ifaces)))) + (defmethod jmake-proxy (interface invocation-handler &optional lisp-this) "Basic implementation that directly uses an invocation handler." - (%jmake-proxy (jclass interface) invocation-handler lisp-this)) + (%jmake-proxy (canonicalize-jproxy-interfaces interface) invocation-handler lisp-this)) (defmethod jmake-proxy (interface (implementation function) &optional lisp-this) "Implements a Java interface forwarding method calls to a Lisp function." - (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation) lisp-this)) + (%jmake-proxy (canonicalize-jproxy-interfaces interface) (jmake-invocation-handler implementation) lisp-this)) (defmethod jmake-proxy (interface (implementation package) &optional lisp-this) "Implements a Java interface mapping Java method names to symbols in a given package. javaMethodName is mapped to a JAVA-METHOD-NAME symbol. An error is signaled if no such symbol exists in the package, or if the symbol exists but does not name a function." @@ -114,7 +120,7 @@ (setf last-lower-p (not upper-p)) (princ (char-upcase char) str))) name))))) - (%jmake-proxy (jclass interface) + (%jmake-proxy (canonicalize-jproxy-interfaces interface) (jmake-invocation-handler (lambda (obj method &rest args) (let ((sym (find-symbol @@ -133,7 +139,7 @@ (defmethod jmake-proxy (interface (implementation hash-table) &optional lisp-this) "Implements a Java interface using closures in an hash-table keyed by Java method name." - (%jmake-proxy (jclass interface) + (%jmake-proxy (canonicalize-jproxy-interfaces interface) (jmake-invocation-handler (lambda (obj method &rest args) (let ((fn (gethash method implementation))) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp Fri Jul 9 17:01:30 2010 @@ -788,7 +788,9 @@ (let ((*precompile-env* (make-environment *precompile-env*)) (operator (car form)) (locals (cadr form)) - (body (cddr form))) + ;; precompile (thus macro-expand) the body before inspecting it + ;; for the use of our locals and optimizing them away + (body (mapcar #'precompile1 (cddr form)))) (dolist (local locals) (let* ((name (car local)) (used-p (find-use name body))) @@ -820,7 +822,7 @@ (return-from precompile-flet/labels (precompile1 new-form)))))) (list* (car form) (precompile-local-functions locals) - (mapcar #'precompile1 body)))) + body))) (defun precompile-function (form) (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA)) From mevenson at common-lisp.net Sat Jul 10 20:08:44 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 10 Jul 2010 16:08:44 -0400 Subject: [armedbear-cvs] r12797 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Jul 10 16:08:43 2010 New Revision: 12797 Log: Convert to a$$-backwards Pollock. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/ShellCommand.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat Jul 10 16:08:43 2010 @@ -606,8 +606,8 @@ // the namestring." 19.2.2.2.3.1 if (host != NIL) { Debug.assertTrue(host instanceof AbstractString - || isURL()); - if (isURL()) { + || host instanceof Cons); + if (host instanceof Cons) { LispObject scheme = Symbol.GETF.execute(host, SCHEME, NIL); LispObject authority = Symbol.GETF.execute(host, AUTHORITY, NIL); Debug.assertTrue(scheme != NIL); @@ -631,7 +631,7 @@ } if (device == NIL) { } else if (device == Keyword.UNSPECIFIC) { - } else if (isJar()) { + } else if (device instanceof Cons) { LispObject[] jars = ((Cons) device).copyToArray(); StringBuilder prefix = new StringBuilder(); for (int i = 0; i < jars.length; i++) { @@ -643,6 +643,9 @@ sb.append("!/"); } sb = prefix.append(sb); + } else if (device instanceof AbstractString + && device.getStringValue().startsWith("jar:")) { + sb.append(device.getStringValue()); } else if (device instanceof AbstractString) { sb.append(device.getStringValue()); if (this instanceof LogicalPathname @@ -720,7 +723,7 @@ } } namestring = sb.toString(); - // XXX Decide if this is necessary + // XXX Decide when this is necessary // if (isURL()) { // namestring = Utilities.uriEncode(namestring); // } @@ -1233,7 +1236,7 @@ namestring = file.getCanonicalPath(); } catch (IOException e) { Debug.trace("Failed to make a Pathname from " - + "'" + file + "'"); + + "." + file + "'"); return null; } return new Pathname(namestring); @@ -1287,7 +1290,7 @@ if (host == NIL) { host = defaults.host; } - if (directory == NIL) { + if (directory == NIL && defaults != null) { directory = defaults.directory; } if (!deviceSupplied) { @@ -2081,8 +2084,7 @@ if (pathname.isURL()) { result = new URL(pathname.getNamestring()); } else { - // XXX Properly encode Windows drive letters and UNC paths - // XXX ensure that we have cannonical path? + // XXX ensure that we have cannonical path. result = new URL("file://" + pathname.getNamestring()); } } catch (MalformedURLException e) { Modified: trunk/abcl/src/org/armedbear/lisp/ShellCommand.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ShellCommand.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ShellCommand.java Sat Jul 10 16:08:43 2010 @@ -235,9 +235,13 @@ // run-shell-command command &key directory (output *standard-output*) // ### %run-shell-command command directory output => exit-code - private static final Primitive _RUN_SHELL_COMMAND = - new Primitive("%run-shell-command", PACKAGE_SYS, false) - { + private static final Primitive _RUN_SHELL_COMMAND = new pf_run_shell_command(); + private static class pf_run_shell_command extends Primitive { + pf_run_shell_command() { + super("%run-shell-command", PACKAGE_SYS, false, + "command directory output => exit-code"); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) From mevenson at common-lisp.net Sat Jul 10 20:22:36 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 10 Jul 2010 16:22:36 -0400 Subject: [armedbear-cvs] r12798 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Jul 10 16:22:36 2010 New Revision: 12798 Log: [HEADS UP] Break Pathname to normalize cross-platform serializations. Convert to forward slash '/' as directory separator in namestring output. FIXME: Breaks UNC paths, as the sequence "//" in "//mount$share/dir/file" gets stripped, whereas the HOST should be interpreted in this case. But who uses these? Please test. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat Jul 10 16:22:36 2010 @@ -61,7 +61,7 @@ // A positive integer, or NIL, :WILD, :UNSPECIFIC, or :NEWEST. protected LispObject version = NIL; - private String namestring; + private volatile String namestring; /** The protocol for changing any instance field (i.e. 'host', 'type', etc.) * is to call this method after changing the field to recompute the namestring. @@ -242,7 +242,7 @@ return; } if (Utilities.isPlatformWindows) { - if (s.startsWith("\\\\")) { + if (s.startsWith("\\\\")) { // XXX What if string starts with '//'? //UNC path support // match \\\\[directories-and-files] @@ -401,24 +401,9 @@ } if (Utilities.isPlatformWindows) { - if (!s.contains(jarSeparator)) { - s = s.replace("/", "\\"); - } else { - StringBuilder result = new StringBuilder(); - for (int i = 0; i < s.length(); i++) { - char c = s.charAt(i); - if ( c != '/') { - result.append(c); - } else { - if (i != 0 && s.charAt(i-1) != '!') { - result.append("\\"); - } else { - result.append(c); - } - } - } - s = result.toString(); - } + if (s.contains("\\")) { + s = s.replace("\\", "/"); + } } // Expand user home directories @@ -438,22 +423,11 @@ } String d = null; // Find last file separator char. - if (Utilities.isPlatformWindows) { - for (int i = s.length(); i-- > 0;) { - char c = s.charAt(i); - if (c == '/' || c == '\\') { - d = s.substring(0, i + 1); - s = s.substring(i + 1); - break; - } - } - } else { - for (int i = s.length(); i-- > 0;) { - if (s.charAt(i) == '/') { - d = s.substring(0, i + 1); - s = s.substring(i + 1); - break; - } + for (int i = s.length(); i-- > 0;) { + if (s.charAt(i) == '/') { + d = s.substring(0, i + 1); + s = s.substring(i + 1); + break; } } if (d != null) { @@ -667,7 +641,7 @@ } if (name instanceof AbstractString) { String n = name.getStringValue(); - if (n.indexOf(File.separatorChar) >= 0) { + if (n.indexOf('/') >= 0) { Debug.assertTrue(namestring == null); return null; } @@ -738,12 +712,7 @@ // is, both NIL and :UNSPECIFIC cause the component not to appear in // the namestring." 19.2.2.2.3.1 if (directory != NIL) { - final char separatorChar; - if (isJar() || isURL()) { - separatorChar = '/'; - } else { - separatorChar = File.separatorChar; - } + final char separatorChar = '/'; LispObject temp = directory; LispObject part = temp.car(); temp = temp.cdr(); @@ -791,18 +760,8 @@ p.invalidateNamestring(); String path = p.getNamestring(); StringBuilder result = new StringBuilder(); - if (Utilities.isPlatformWindows) { - for (int i = 0; i < path.length(); i++) { - char c = path.charAt(i); - if (c == '\\') { - result.append('/'); - } else { - result.append(c); - } - } - } else { - result.append(path); - } + result.append(path); + // Entries in jar files are always relative, but Pathname // directories are :ABSOLUTE. if (result.length() > 1 @@ -904,7 +863,7 @@ } } } - } else { + } else { useNamestring = false; } StringBuilder sb = new StringBuilder(); @@ -926,41 +885,53 @@ sb.append('"'); } } else { - sb.append("#P("); + final boolean ANSI_COMPATIBLE = true; + final String separator; + if (ANSI_COMPATIBLE) { + sb.append("#P("); + separator = "\""; + } else { + sb.append("#P("); + separator = " "; + } if (host != NIL) { sb.append(":HOST "); sb.append(host.writeToString()); - sb.append(' '); + sb.append(separator); } if (device != NIL) { sb.append(":DEVICE "); sb.append(device.writeToString()); - sb.append(' '); + sb.append(separator); } if (directory != NIL) { sb.append(":DIRECTORY "); sb.append(directory.writeToString()); - sb.append(" "); + sb.append(separator); } if (name != NIL) { sb.append(":NAME "); sb.append(name.writeToString()); - sb.append(' '); + sb.append(separator); } if (type != NIL) { sb.append(":TYPE "); sb.append(type.writeToString()); - sb.append(' '); + sb.append(separator); } if (version != NIL) { sb.append(":VERSION "); sb.append(version.writeToString()); - sb.append(' '); + sb.append(separator); } - if (sb.charAt(sb.length() - 1) == ' ') { + if (sb.charAt(sb.length() - 1) == ' ') { // XXX sb.setLength(sb.length() - 1); } - sb.append(')'); + if (ANSI_COMPATIBLE) { + sb.append(')' + separator); + } else { + sb.append(')'); + } } return sb.toString(); } @@ -1378,6 +1349,7 @@ final int limit = s.length(); for (int i = 0; i < limit; i++) { char c = s.charAt(i); + // XXX '\\' should be illegal in all Pathnames at this point? if (c == '/' || c == '\\' && Utilities.isPlatformWindows) { error(new LispError("Invalid character #\\" + c + " in pathname component \"" + s From mevenson at common-lisp.net Sat Jul 10 20:37:05 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 10 Jul 2010 16:37:05 -0400 Subject: [armedbear-cvs] r12799 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Jul 10 16:37:04 2010 New Revision: 12799 Log: Backout partial bad merge. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat Jul 10 16:37:04 2010 @@ -580,8 +580,8 @@ // the namestring." 19.2.2.2.3.1 if (host != NIL) { Debug.assertTrue(host instanceof AbstractString - || host instanceof Cons); - if (host instanceof Cons) { + || isURL()); + if (isURL()) { LispObject scheme = Symbol.GETF.execute(host, SCHEME, NIL); LispObject authority = Symbol.GETF.execute(host, AUTHORITY, NIL); Debug.assertTrue(scheme != NIL); @@ -605,7 +605,7 @@ } if (device == NIL) { } else if (device == Keyword.UNSPECIFIC) { - } else if (device instanceof Cons) { + } else if (isJar()) { LispObject[] jars = ((Cons) device).copyToArray(); StringBuilder prefix = new StringBuilder(); for (int i = 0; i < jars.length; i++) { @@ -617,9 +617,6 @@ sb.append("!/"); } sb = prefix.append(sb); - } else if (device instanceof AbstractString - && device.getStringValue().startsWith("jar:")) { - sb.append(device.getStringValue()); } else if (device instanceof AbstractString) { sb.append(device.getStringValue()); if (this instanceof LogicalPathname @@ -697,7 +694,7 @@ } } namestring = sb.toString(); - // XXX Decide when this is necessary + // XXX Decide if this is necessary // if (isURL()) { // namestring = Utilities.uriEncode(namestring); // } @@ -1261,7 +1258,7 @@ if (host == NIL) { host = defaults.host; } - if (directory == NIL && defaults != null) { + if (directory == NIL) { directory = defaults.directory; } if (!deviceSupplied) { @@ -2056,7 +2053,8 @@ if (pathname.isURL()) { result = new URL(pathname.getNamestring()); } else { - // XXX ensure that we have cannonical path. + // XXX Properly encode Windows drive letters and UNC paths + // XXX ensure that we have cannonical path? result = new URL("file://" + pathname.getNamestring()); } } catch (MalformedURLException e) { From mevenson at common-lisp.net Sun Jul 11 07:19:16 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 11 Jul 2010 03:19:16 -0400 Subject: [armedbear-cvs] r12800 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Jul 11 03:19:13 2010 New Revision: 12800 Log: Add documentation markers for etags groveling for new functions. Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java 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 Sun Jul 11 03:19:13 2010 @@ -150,6 +150,7 @@ } }; + // ### make-classloader &optional parent => java-class-loader private static final Primitive MAKE_CLASSLOADER = new pf_make_classloader(); private static final class pf_make_classloader extends Primitive { @@ -169,6 +170,7 @@ } }; + // ### dump-classpath &optional classloader => list-of-pathname-lists private static final Primitive DUMP_CLASSPATH = new pf_dump_classpath(); private static final class pf_dump_classpath extends Primitive { @@ -195,6 +197,7 @@ } }; + // ### add-to-classpath jar-or-jars &optional (classloader (get-current-classloader)) private static final Primitive ADD_TO_CLASSPATH = new pf_add_to_classpath(); private static final class pf_add_to_classpath extends Primitive { From mevenson at common-lisp.net Sun Jul 11 20:03:24 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 11 Jul 2010 16:03:24 -0400 Subject: [armedbear-cvs] r12801 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Jul 11 16:03:22 2010 New Revision: 12801 Log: MAKE-PATHNAME will now make UNC paths. If the HOST passed by MAKE-PATHNAME is not a defined logical host, a UNC pathname is constructed (on all platforms). Fix namestrings to plausibly be ANSI defined strings. Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java trunk/abcl/src/org/armedbear/lisp/Pathname.java 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 Sun Jul 11 16:03:22 2010 @@ -150,7 +150,6 @@ } }; - // ### make-classloader &optional parent => java-class-loader private static final Primitive MAKE_CLASSLOADER = new pf_make_classloader(); private static final class pf_make_classloader extends Primitive { @@ -170,7 +169,6 @@ } }; - // ### dump-classpath &optional classloader => list-of-pathname-lists private static final Primitive DUMP_CLASSPATH = new pf_dump_classpath(); private static final class pf_dump_classpath extends Primitive { @@ -197,7 +195,6 @@ } }; - // ### add-to-classpath jar-or-jars &optional (classloader (get-current-classloader)) private static final Primitive ADD_TO_CLASSPATH = new pf_add_to_classpath(); private static final class pf_add_to_classpath extends Primitive { Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sun Jul 11 16:03:22 2010 @@ -591,16 +591,12 @@ sb.append("//"); sb.append(authority.getStringValue()); } - } else { - if (!(this instanceof LogicalPathname)) { - sb.append("\\\\"); //UNC file support; if there's a host, it's a UNC path. - } + } else if (this instanceof LogicalPathname) { sb.append(host.getStringValue()); - if (this instanceof LogicalPathname) { - sb.append(':'); - } else { - sb.append(File.separatorChar); - } + sb.append(':'); + } else { + // UNC paths now use unprintable representation + return null; } } if (device == NIL) { @@ -837,8 +833,8 @@ @Override public String writeToString() { final LispThread thread = LispThread.currentThread(); - boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); - boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); + final boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); + final boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); boolean useNamestring; String s = null; s = getNamestring(); @@ -882,52 +878,57 @@ sb.append('"'); } } else { - final boolean ANSI_COMPATIBLE = true; - final String separator; - if (ANSI_COMPATIBLE) { - sb.append("#P("); - separator = "\""; - } else { - sb.append("#P("); - separator = " "; - } - if (host != NIL) { - sb.append(":HOST "); - sb.append(host.writeToString()); - sb.append(separator); - } - if (device != NIL) { - sb.append(":DEVICE "); - sb.append(device.writeToString()); - sb.append(separator); - } - if (directory != NIL) { - sb.append(":DIRECTORY "); - sb.append(directory.writeToString()); - sb.append(separator); - } - if (name != NIL) { - sb.append(":NAME "); - sb.append(name.writeToString()); - sb.append(separator); - } - if (type != NIL) { - sb.append(":TYPE "); - sb.append(type.writeToString()); - sb.append(separator); - } - if (version != NIL) { - sb.append(":VERSION "); - sb.append(version.writeToString()); - sb.append(separator); - } - if (sb.charAt(sb.length() - 1) == ' ') { // XXX - sb.setLength(sb.length() - 1); - } - if (ANSI_COMPATIBLE) { - sb.append(')' + separator); - } else { - sb.append(')'); + final SpecialBindingsMark mark = thread.markSpecialBindings(); + thread.bindSpecial(Symbol.PRINT_ESCAPE, T); + try { + final boolean ANSI_COMPATIBLE = true; + final String SPACE = " "; + if (ANSI_COMPATIBLE) { + sb.append("#P(\""); + } else { + sb.append("#P("); + + } + if (host != NIL) { + sb.append(":HOST "); + sb.append(host.writeToString()); + sb.append(SPACE); + } + if (device != NIL) { + sb.append(":DEVICE "); + sb.append(device.writeToString()); + sb.append(SPACE); + } + if (directory != NIL) { + sb.append(":DIRECTORY "); + sb.append(directory.writeToString()); + sb.append(SPACE); + } + if (name != NIL) { + sb.append(":NAME "); + sb.append(name.writeToString()); + sb.append(SPACE); + } + if (type != NIL) { + sb.append(":TYPE "); + sb.append(type.writeToString()); + sb.append(SPACE); + } + if (version != NIL) { + sb.append(":VERSION "); + sb.append(version.writeToString()); + sb.append(SPACE); + } + if (sb.charAt(sb.length() - 1) == ' ') { // XXX + sb.setLength(sb.length() - 1); + } + if (ANSI_COMPATIBLE) { + sb.append(')' + "\""); + } else { + sb.append(')'); + } + } finally { + thread.resetSpecialBindings(mark); } } return sb.toString(); @@ -1273,17 +1274,22 @@ } final Pathname p; final boolean logical; + LispObject logicalHost = NIL; if (host != NIL) { if (host instanceof AbstractString) { - host = LogicalPathname.canonicalizeStringComponent((AbstractString) host); + logicalHost = LogicalPathname.canonicalizeStringComponent((AbstractString) host); + } + if (LOGICAL_PATHNAME_TRANSLATIONS.get(logicalHost) == null) { + // Not a defined logical pathname host -- A UNC path + //warning(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); + p = new Pathname(); + logical = false; + p.host = host; + } else { + p = new LogicalPathname(); + logical = true; + p.host = logicalHost; } - if (LOGICAL_PATHNAME_TRANSLATIONS.get(host) == null) { - // Not a defined logical pathname host. - error(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); - } - p = new LogicalPathname(); - logical = true; - p.host = host; p.device = Keyword.UNSPECIFIC; } else { p = new Pathname(); From mevenson at common-lisp.net Mon Jul 12 09:51:20 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 12 Jul 2010 05:51:20 -0400 Subject: [armedbear-cvs] r12802 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Jul 12 05:51:19 2010 New Revision: 12802 Log: Re-apply grovel tags patch. Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/ShellCommand.java 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 Mon Jul 12 05:51:19 2010 @@ -150,6 +150,7 @@ } }; + // ### make-classloader &optional parent => java-class-loader private static final Primitive MAKE_CLASSLOADER = new pf_make_classloader(); private static final class pf_make_classloader extends Primitive { @@ -169,6 +170,7 @@ } }; + // ### dump-classpath &optional classloader => list-of-pathname-lists private static final Primitive DUMP_CLASSPATH = new pf_dump_classpath(); private static final class pf_dump_classpath extends Primitive { @@ -195,6 +197,7 @@ } }; + // ### add-to-classpath jar-or-jars &optional (classloader (get-current-classloader)) private static final Primitive ADD_TO_CLASSPATH = new pf_add_to_classpath(); private static final class pf_add_to_classpath extends Primitive { Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Mon Jul 12 05:51:19 2010 @@ -61,7 +61,7 @@ // A positive integer, or NIL, :WILD, :UNSPECIFIC, or :NEWEST. protected LispObject version = NIL; - private volatile String namestring; + private String namestring; /** The protocol for changing any instance field (i.e. 'host', 'type', etc.) * is to call this method after changing the field to recompute the namestring. @@ -242,7 +242,7 @@ return; } if (Utilities.isPlatformWindows) { - if (s.startsWith("\\\\")) { // XXX What if string starts with '//'? + if (s.startsWith("\\\\")) { //UNC path support // match \\\\[directories-and-files] @@ -401,9 +401,24 @@ } if (Utilities.isPlatformWindows) { - if (s.contains("\\")) { - s = s.replace("\\", "/"); - } + if (!s.contains(jarSeparator)) { + s = s.replace("/", "\\"); + } else { + StringBuilder result = new StringBuilder(); + for (int i = 0; i < s.length(); i++) { + char c = s.charAt(i); + if ( c != '/') { + result.append(c); + } else { + if (i != 0 && s.charAt(i-1) != '!') { + result.append("\\"); + } else { + result.append(c); + } + } + } + s = result.toString(); + } } // Expand user home directories @@ -423,11 +438,22 @@ } String d = null; // Find last file separator char. - for (int i = s.length(); i-- > 0;) { - if (s.charAt(i) == '/') { - d = s.substring(0, i + 1); - s = s.substring(i + 1); - break; + if (Utilities.isPlatformWindows) { + for (int i = s.length(); i-- > 0;) { + char c = s.charAt(i); + if (c == '/' || c == '\\') { + d = s.substring(0, i + 1); + s = s.substring(i + 1); + break; + } + } + } else { + for (int i = s.length(); i-- > 0;) { + if (s.charAt(i) == '/') { + d = s.substring(0, i + 1); + s = s.substring(i + 1); + break; + } } } if (d != null) { @@ -591,12 +617,16 @@ sb.append("//"); sb.append(authority.getStringValue()); } - } else if (this instanceof LogicalPathname) { + } else { + if (!(this instanceof LogicalPathname)) { + sb.append("\\\\"); //UNC file support; if there's a host, it's a UNC path. + } sb.append(host.getStringValue()); - sb.append(':'); - } else { - // UNC paths now use unprintable representation - return null; + if (this instanceof LogicalPathname) { + sb.append(':'); + } else { + sb.append(File.separatorChar); + } } } if (device == NIL) { @@ -634,7 +664,7 @@ } if (name instanceof AbstractString) { String n = name.getStringValue(); - if (n.indexOf('/') >= 0) { + if (n.indexOf(File.separatorChar) >= 0) { Debug.assertTrue(namestring == null); return null; } @@ -705,7 +735,12 @@ // is, both NIL and :UNSPECIFIC cause the component not to appear in // the namestring." 19.2.2.2.3.1 if (directory != NIL) { - final char separatorChar = '/'; + final char separatorChar; + if (isJar() || isURL()) { + separatorChar = '/'; + } else { + separatorChar = File.separatorChar; + } LispObject temp = directory; LispObject part = temp.car(); temp = temp.cdr(); @@ -753,8 +788,18 @@ p.invalidateNamestring(); String path = p.getNamestring(); StringBuilder result = new StringBuilder(); - result.append(path); - + if (Utilities.isPlatformWindows) { + for (int i = 0; i < path.length(); i++) { + char c = path.charAt(i); + if (c == '\\') { + result.append('/'); + } else { + result.append(c); + } + } + } else { + result.append(path); + } // Entries in jar files are always relative, but Pathname // directories are :ABSOLUTE. if (result.length() > 1 @@ -833,8 +878,8 @@ @Override public String writeToString() { final LispThread thread = LispThread.currentThread(); - final boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); - final boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); + boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); + boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); boolean useNamestring; String s = null; s = getNamestring(); @@ -856,7 +901,7 @@ } } } - } else { + } else { useNamestring = false; } StringBuilder sb = new StringBuilder(); @@ -878,58 +923,41 @@ sb.append('"'); } } else { - final SpecialBindingsMark mark = thread.markSpecialBindings(); - thread.bindSpecial(Symbol.PRINT_ESCAPE, T); - try { - final boolean ANSI_COMPATIBLE = true; - final String SPACE = " "; - if (ANSI_COMPATIBLE) { - sb.append("#P(\""); - } else { - sb.append("#P("); - - } - if (host != NIL) { - sb.append(":HOST "); - sb.append(host.writeToString()); - sb.append(SPACE); - } - if (device != NIL) { - sb.append(":DEVICE "); - sb.append(device.writeToString()); - sb.append(SPACE); - } - if (directory != NIL) { - sb.append(":DIRECTORY "); - sb.append(directory.writeToString()); - sb.append(SPACE); - } - if (name != NIL) { - sb.append(":NAME "); - sb.append(name.writeToString()); - sb.append(SPACE); - } - if (type != NIL) { - sb.append(":TYPE "); - sb.append(type.writeToString()); - sb.append(SPACE); - } - if (version != NIL) { - sb.append(":VERSION "); - sb.append(version.writeToString()); - sb.append(SPACE); - } - if (sb.charAt(sb.length() - 1) == ' ') { // XXX - sb.setLength(sb.length() - 1); - } - if (ANSI_COMPATIBLE) { - sb.append(')' + "\""); - } else { - sb.append(')'); - } - } finally { - thread.resetSpecialBindings(mark); + sb.append("#P("); + if (host != NIL) { + sb.append(":HOST "); + sb.append(host.writeToString()); + sb.append(' '); + } + if (device != NIL) { + sb.append(":DEVICE "); + sb.append(device.writeToString()); + sb.append(' '); + } + if (directory != NIL) { + sb.append(":DIRECTORY "); + sb.append(directory.writeToString()); + sb.append(" "); + } + if (name != NIL) { + sb.append(":NAME "); + sb.append(name.writeToString()); + sb.append(' '); + } + if (type != NIL) { + sb.append(":TYPE "); + sb.append(type.writeToString()); + sb.append(' '); + } + if (version != NIL) { + sb.append(":VERSION "); + sb.append(version.writeToString()); + sb.append(' '); } + if (sb.charAt(sb.length() - 1) == ' ') { + sb.setLength(sb.length() - 1); + } + sb.append(')'); } return sb.toString(); } @@ -1205,7 +1233,7 @@ namestring = file.getCanonicalPath(); } catch (IOException e) { Debug.trace("Failed to make a Pathname from " - + "." + file + "'"); + + "'" + file + "'"); return null; } return new Pathname(namestring); @@ -1274,22 +1302,17 @@ } final Pathname p; final boolean logical; - LispObject logicalHost = NIL; if (host != NIL) { if (host instanceof AbstractString) { - logicalHost = LogicalPathname.canonicalizeStringComponent((AbstractString) host); - } - if (LOGICAL_PATHNAME_TRANSLATIONS.get(logicalHost) == null) { - // Not a defined logical pathname host -- A UNC path - //warning(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); - p = new Pathname(); - logical = false; - p.host = host; - } else { - p = new LogicalPathname(); - logical = true; - p.host = logicalHost; + host = LogicalPathname.canonicalizeStringComponent((AbstractString) host); } + if (LOGICAL_PATHNAME_TRANSLATIONS.get(host) == null) { + // Not a defined logical pathname host. + error(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); + } + p = new LogicalPathname(); + logical = true; + p.host = host; p.device = Keyword.UNSPECIFIC; } else { p = new Pathname(); @@ -1352,7 +1375,6 @@ final int limit = s.length(); for (int i = 0; i < limit; i++) { char c = s.charAt(i); - // XXX '\\' should be illegal in all Pathnames at this point? if (c == '/' || c == '\\' && Utilities.isPlatformWindows) { error(new LispError("Invalid character #\\" + c + " in pathname component \"" + s Modified: trunk/abcl/src/org/armedbear/lisp/ShellCommand.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ShellCommand.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ShellCommand.java Mon Jul 12 05:51:19 2010 @@ -235,13 +235,9 @@ // run-shell-command command &key directory (output *standard-output*) // ### %run-shell-command command directory output => exit-code - private static final Primitive _RUN_SHELL_COMMAND = new pf_run_shell_command(); - private static class pf_run_shell_command extends Primitive { - pf_run_shell_command() { - super("%run-shell-command", PACKAGE_SYS, false, - "command directory output => exit-code"); - } - + private static final Primitive _RUN_SHELL_COMMAND = + new Primitive("%run-shell-command", PACKAGE_SYS, false) + { @Override public LispObject execute(LispObject first, LispObject second, LispObject third) From mevenson at common-lisp.net Mon Jul 12 09:55:12 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 12 Jul 2010 05:55:12 -0400 Subject: [armedbear-cvs] r12803 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Jul 12 05:55:11 2010 New Revision: 12803 Log: Revert bad commit. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/ShellCommand.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Mon Jul 12 05:55:11 2010 @@ -61,7 +61,7 @@ // A positive integer, or NIL, :WILD, :UNSPECIFIC, or :NEWEST. protected LispObject version = NIL; - private String namestring; + private volatile String namestring; /** The protocol for changing any instance field (i.e. 'host', 'type', etc.) * is to call this method after changing the field to recompute the namestring. @@ -242,7 +242,7 @@ return; } if (Utilities.isPlatformWindows) { - if (s.startsWith("\\\\")) { + if (s.startsWith("\\\\")) { // XXX What if string starts with '//'? //UNC path support // match \\\\[directories-and-files] @@ -401,24 +401,9 @@ } if (Utilities.isPlatformWindows) { - if (!s.contains(jarSeparator)) { - s = s.replace("/", "\\"); - } else { - StringBuilder result = new StringBuilder(); - for (int i = 0; i < s.length(); i++) { - char c = s.charAt(i); - if ( c != '/') { - result.append(c); - } else { - if (i != 0 && s.charAt(i-1) != '!') { - result.append("\\"); - } else { - result.append(c); - } - } - } - s = result.toString(); - } + if (s.contains("\\")) { + s = s.replace("\\", "/"); + } } // Expand user home directories @@ -438,22 +423,11 @@ } String d = null; // Find last file separator char. - if (Utilities.isPlatformWindows) { - for (int i = s.length(); i-- > 0;) { - char c = s.charAt(i); - if (c == '/' || c == '\\') { - d = s.substring(0, i + 1); - s = s.substring(i + 1); - break; - } - } - } else { - for (int i = s.length(); i-- > 0;) { - if (s.charAt(i) == '/') { - d = s.substring(0, i + 1); - s = s.substring(i + 1); - break; - } + for (int i = s.length(); i-- > 0;) { + if (s.charAt(i) == '/') { + d = s.substring(0, i + 1); + s = s.substring(i + 1); + break; } } if (d != null) { @@ -617,16 +591,12 @@ sb.append("//"); sb.append(authority.getStringValue()); } - } else { - if (!(this instanceof LogicalPathname)) { - sb.append("\\\\"); //UNC file support; if there's a host, it's a UNC path. - } + } else if (this instanceof LogicalPathname) { sb.append(host.getStringValue()); - if (this instanceof LogicalPathname) { - sb.append(':'); - } else { - sb.append(File.separatorChar); - } + sb.append(':'); + } else { + // UNC paths now use unprintable representation + return null; } } if (device == NIL) { @@ -664,7 +634,7 @@ } if (name instanceof AbstractString) { String n = name.getStringValue(); - if (n.indexOf(File.separatorChar) >= 0) { + if (n.indexOf('/') >= 0) { Debug.assertTrue(namestring == null); return null; } @@ -735,12 +705,7 @@ // is, both NIL and :UNSPECIFIC cause the component not to appear in // the namestring." 19.2.2.2.3.1 if (directory != NIL) { - final char separatorChar; - if (isJar() || isURL()) { - separatorChar = '/'; - } else { - separatorChar = File.separatorChar; - } + final char separatorChar = '/'; LispObject temp = directory; LispObject part = temp.car(); temp = temp.cdr(); @@ -788,18 +753,8 @@ p.invalidateNamestring(); String path = p.getNamestring(); StringBuilder result = new StringBuilder(); - if (Utilities.isPlatformWindows) { - for (int i = 0; i < path.length(); i++) { - char c = path.charAt(i); - if (c == '\\') { - result.append('/'); - } else { - result.append(c); - } - } - } else { - result.append(path); - } + result.append(path); + // Entries in jar files are always relative, but Pathname // directories are :ABSOLUTE. if (result.length() > 1 @@ -878,8 +833,8 @@ @Override public String writeToString() { final LispThread thread = LispThread.currentThread(); - boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); - boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); + final boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); + final boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); boolean useNamestring; String s = null; s = getNamestring(); @@ -901,7 +856,7 @@ } } } - } else { + } else { useNamestring = false; } StringBuilder sb = new StringBuilder(); @@ -923,41 +878,58 @@ sb.append('"'); } } else { - sb.append("#P("); - if (host != NIL) { - sb.append(":HOST "); - sb.append(host.writeToString()); - sb.append(' '); - } - if (device != NIL) { - sb.append(":DEVICE "); - sb.append(device.writeToString()); - sb.append(' '); - } - if (directory != NIL) { - sb.append(":DIRECTORY "); - sb.append(directory.writeToString()); - sb.append(" "); - } - if (name != NIL) { - sb.append(":NAME "); - sb.append(name.writeToString()); - sb.append(' '); - } - if (type != NIL) { - sb.append(":TYPE "); - sb.append(type.writeToString()); - sb.append(' '); - } - if (version != NIL) { - sb.append(":VERSION "); - sb.append(version.writeToString()); - sb.append(' '); - } - if (sb.charAt(sb.length() - 1) == ' ') { - sb.setLength(sb.length() - 1); + final SpecialBindingsMark mark = thread.markSpecialBindings(); + thread.bindSpecial(Symbol.PRINT_ESCAPE, T); + try { + final boolean ANSI_COMPATIBLE = true; + final String SPACE = " "; + if (ANSI_COMPATIBLE) { + sb.append("#P(\""); + } else { + sb.append("#P("); + + } + if (host != NIL) { + sb.append(":HOST "); + sb.append(host.writeToString()); + sb.append(SPACE); + } + if (device != NIL) { + sb.append(":DEVICE "); + sb.append(device.writeToString()); + sb.append(SPACE); + } + if (directory != NIL) { + sb.append(":DIRECTORY "); + sb.append(directory.writeToString()); + sb.append(SPACE); + } + if (name != NIL) { + sb.append(":NAME "); + sb.append(name.writeToString()); + sb.append(SPACE); + } + if (type != NIL) { + sb.append(":TYPE "); + sb.append(type.writeToString()); + sb.append(SPACE); + } + if (version != NIL) { + sb.append(":VERSION "); + sb.append(version.writeToString()); + sb.append(SPACE); + } + if (sb.charAt(sb.length() - 1) == ' ') { // XXX + sb.setLength(sb.length() - 1); + } + if (ANSI_COMPATIBLE) { + sb.append(')' + "\""); + } else { + sb.append(')'); + } + } finally { + thread.resetSpecialBindings(mark); } - sb.append(')'); } return sb.toString(); } @@ -1233,7 +1205,7 @@ namestring = file.getCanonicalPath(); } catch (IOException e) { Debug.trace("Failed to make a Pathname from " - + "'" + file + "'"); + + "." + file + "'"); return null; } return new Pathname(namestring); @@ -1302,17 +1274,22 @@ } final Pathname p; final boolean logical; + LispObject logicalHost = NIL; if (host != NIL) { if (host instanceof AbstractString) { - host = LogicalPathname.canonicalizeStringComponent((AbstractString) host); + logicalHost = LogicalPathname.canonicalizeStringComponent((AbstractString) host); + } + if (LOGICAL_PATHNAME_TRANSLATIONS.get(logicalHost) == null) { + // Not a defined logical pathname host -- A UNC path + //warning(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); + p = new Pathname(); + logical = false; + p.host = host; + } else { + p = new LogicalPathname(); + logical = true; + p.host = logicalHost; } - if (LOGICAL_PATHNAME_TRANSLATIONS.get(host) == null) { - // Not a defined logical pathname host. - error(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); - } - p = new LogicalPathname(); - logical = true; - p.host = host; p.device = Keyword.UNSPECIFIC; } else { p = new Pathname(); @@ -1375,6 +1352,7 @@ final int limit = s.length(); for (int i = 0; i < limit; i++) { char c = s.charAt(i); + // XXX '\\' should be illegal in all Pathnames at this point? if (c == '/' || c == '\\' && Utilities.isPlatformWindows) { error(new LispError("Invalid character #\\" + c + " in pathname component \"" + s Modified: trunk/abcl/src/org/armedbear/lisp/ShellCommand.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ShellCommand.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ShellCommand.java Mon Jul 12 05:55:11 2010 @@ -235,9 +235,13 @@ // run-shell-command command &key directory (output *standard-output*) // ### %run-shell-command command directory output => exit-code - private static final Primitive _RUN_SHELL_COMMAND = - new Primitive("%run-shell-command", PACKAGE_SYS, false) - { + private static final Primitive _RUN_SHELL_COMMAND = new pf_run_shell_command(); + private static class pf_run_shell_command extends Primitive { + pf_run_shell_command() { + super("%run-shell-command", PACKAGE_SYS, false, + "command directory output => exit-code"); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) From astalla at common-lisp.net Mon Jul 12 21:05:29 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 12 Jul 2010 17:05:29 -0400 Subject: [armedbear-cvs] r12804 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Jul 12 17:05:28 2010 New Revision: 12804 Log: Fix r12768: macroexpand the body in an environment augmented with the newly-introduced function definitions to shadow macros with the same names. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Mon Jul 12 17:05:28 2010 @@ -788,9 +788,15 @@ (let ((*precompile-env* (make-environment *precompile-env*)) (operator (car form)) (locals (cadr form)) - ;; precompile (thus macro-expand) the body before inspecting it - ;; for the use of our locals and optimizing them away - (body (mapcar #'precompile1 (cddr form)))) + body) + ;; first augment the environment with the newly-defined local functions + ;; to shadow preexisting macro definitions with the same names + (dolist (local locals) + (environment-add-function-definition *precompile-env* + (car local) (cddr local))) + ;; then precompile (thus macro-expand) the body before inspecting it + ;; for the use of our locals and optimizing them away + (setq body (mapcar #'precompile1 (cddr form))) (dolist (local locals) (let* ((name (car local)) (used-p (find-use name body))) From astalla at common-lisp.net Tue Jul 13 19:16:27 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 13 Jul 2010 15:16:27 -0400 Subject: [armedbear-cvs] r12805 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Jul 13 15:16:25 2010 New Revision: 12805 Log: Fixed bugs with custom slot and class options Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp 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 Tue Jul 13 15:16:25 2010 @@ -209,11 +209,8 @@ (push-on-end (cadr olist) readers) (push-on-end `(setf ,(cadr olist)) writers)) (t - (push-on-end (car olist) non-std-options) + (push-on-end `(quote ,(car olist)) non-std-options) (push-on-end (cadr olist) non-std-options)))) -; (error 'program-error -; "invalid initialization argument ~S for slot named ~S" -; (car olist) name)) `(list :name ',name ,@(when initfunction @@ -259,10 +256,7 @@ (cdr option)))))) ((:documentation :report) (list (car option) `',(cadr option))) - (t (list (car option) `(quote ,(cdr option)))))) -; (error 'program-error -; :format-control "invalid DEFCLASS option ~S" -; :format-arguments (list (car option)))))) + (t (list `(quote ,(car option)) `(quote ,(cdr option)))))) (defun make-initfunction (initform) `(function (lambda () ,initform))) @@ -337,8 +331,7 @@ (readers ()) (writers ()) (allocation :instance) - (allocation-class nil) - &allow-other-keys) + (allocation-class nil)) (setf (slot-definition-name slot) name) (setf (slot-definition-initargs slot) initargs) (setf (slot-definition-initform slot) initform) @@ -2339,7 +2332,7 @@ (declare (ignore slot-names)) ;;TODO? (declare (ignore name initargs initform initfunction readers writers allocation)) ;;For built-in slots - (apply #'init-slot-definition slot args) + (apply #'init-slot-definition slot :allow-other-keys t args) ;;For user-defined slots (call-next-method)) From ehuelsmann at common-lisp.net Thu Jul 15 21:43:06 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 15 Jul 2010 17:43:06 -0400 Subject: [armedbear-cvs] r12806 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 15 17:43:05 2010 New Revision: 12806 Log: Rename 'local-variable-p' to 'variable-local-p' because jvm-class-file.lisp defines a 'local-variable' structure which implicitly creates a function by the same name. Found by: astalla Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jul 15 17:43:05 2010 @@ -706,7 +706,7 @@ (ensure-thread-var-initialized) (aload *thread*)) -(defun local-variable-p (variable) +(defun variable-local-p (variable) "Return non-NIL if `variable' is a local variable. Special variables are not considered local." @@ -715,7 +715,7 @@ (defun emit-load-local-variable (variable) "Loads a local variable in the top stack position." - (aver (local-variable-p variable)) + (aver (variable-local-p variable)) (if (variable-register variable) (aload (variable-register variable)) (progn @@ -733,7 +733,7 @@ The stack pointer is returned to the position from before the emitted code: the code is 'stack-neutral'." (declare (type symbol expected-type)) - (unless (local-variable-p variable) + (unless (variable-local-p variable) (return-from generate-instanceof-type-check-for-variable)) (let ((instanceof-class (ecase expected-type (SYMBOL +lisp-symbol+) From ehuelsmann at common-lisp.net Thu Jul 15 22:06:44 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 15 Jul 2010 18:06:44 -0400 Subject: [armedbear-cvs] r12807 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 15 18:06:43 2010 New Revision: 12807 Log: Backport r12796-12805 from trunk. Reduces the current 37 ANSI failures to 34. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java branches/generic-class-file/abcl/src/org/armedbear/lisp/ShellCommand.java branches/generic-class-file/abcl/src/org/armedbear/lisp/clos.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaClassLoader.java Thu Jul 15 18:06:43 2010 @@ -150,6 +150,7 @@ } }; + // ### make-classloader &optional parent => java-class-loader private static final Primitive MAKE_CLASSLOADER = new pf_make_classloader(); private static final class pf_make_classloader extends Primitive { @@ -169,6 +170,7 @@ } }; + // ### dump-classpath &optional classloader => list-of-pathname-lists private static final Primitive DUMP_CLASSPATH = new pf_dump_classpath(); private static final class pf_dump_classpath extends Primitive { @@ -195,6 +197,7 @@ } }; + // ### add-to-classpath jar-or-jars &optional (classloader (get-current-classloader)) private static final Primitive ADD_TO_CLASSPATH = new pf_add_to_classpath(); private static final class pf_add_to_classpath extends Primitive { Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java Thu Jul 15 18:06:43 2010 @@ -61,7 +61,7 @@ // A positive integer, or NIL, :WILD, :UNSPECIFIC, or :NEWEST. protected LispObject version = NIL; - private String namestring; + private volatile String namestring; /** The protocol for changing any instance field (i.e. 'host', 'type', etc.) * is to call this method after changing the field to recompute the namestring. @@ -242,7 +242,7 @@ return; } if (Utilities.isPlatformWindows) { - if (s.startsWith("\\\\")) { + if (s.startsWith("\\\\")) { // XXX What if string starts with '//'? //UNC path support // match \\\\[directories-and-files] @@ -401,24 +401,9 @@ } if (Utilities.isPlatformWindows) { - if (!s.contains(jarSeparator)) { - s = s.replace("/", "\\"); - } else { - StringBuilder result = new StringBuilder(); - for (int i = 0; i < s.length(); i++) { - char c = s.charAt(i); - if ( c != '/') { - result.append(c); - } else { - if (i != 0 && s.charAt(i-1) != '!') { - result.append("\\"); - } else { - result.append(c); - } - } - } - s = result.toString(); - } + if (s.contains("\\")) { + s = s.replace("\\", "/"); + } } // Expand user home directories @@ -438,22 +423,11 @@ } String d = null; // Find last file separator char. - if (Utilities.isPlatformWindows) { - for (int i = s.length(); i-- > 0;) { - char c = s.charAt(i); - if (c == '/' || c == '\\') { - d = s.substring(0, i + 1); - s = s.substring(i + 1); - break; - } - } - } else { - for (int i = s.length(); i-- > 0;) { - if (s.charAt(i) == '/') { - d = s.substring(0, i + 1); - s = s.substring(i + 1); - break; - } + for (int i = s.length(); i-- > 0;) { + if (s.charAt(i) == '/') { + d = s.substring(0, i + 1); + s = s.substring(i + 1); + break; } } if (d != null) { @@ -617,16 +591,12 @@ sb.append("//"); sb.append(authority.getStringValue()); } - } else { - if (!(this instanceof LogicalPathname)) { - sb.append("\\\\"); //UNC file support; if there's a host, it's a UNC path. - } + } else if (this instanceof LogicalPathname) { sb.append(host.getStringValue()); - if (this instanceof LogicalPathname) { - sb.append(':'); - } else { - sb.append(File.separatorChar); - } + sb.append(':'); + } else { + // UNC paths now use unprintable representation + return null; } } if (device == NIL) { @@ -664,7 +634,7 @@ } if (name instanceof AbstractString) { String n = name.getStringValue(); - if (n.indexOf(File.separatorChar) >= 0) { + if (n.indexOf('/') >= 0) { Debug.assertTrue(namestring == null); return null; } @@ -735,12 +705,7 @@ // is, both NIL and :UNSPECIFIC cause the component not to appear in // the namestring." 19.2.2.2.3.1 if (directory != NIL) { - final char separatorChar; - if (isJar() || isURL()) { - separatorChar = '/'; - } else { - separatorChar = File.separatorChar; - } + final char separatorChar = '/'; LispObject temp = directory; LispObject part = temp.car(); temp = temp.cdr(); @@ -788,18 +753,8 @@ p.invalidateNamestring(); String path = p.getNamestring(); StringBuilder result = new StringBuilder(); - if (Utilities.isPlatformWindows) { - for (int i = 0; i < path.length(); i++) { - char c = path.charAt(i); - if (c == '\\') { - result.append('/'); - } else { - result.append(c); - } - } - } else { - result.append(path); - } + result.append(path); + // Entries in jar files are always relative, but Pathname // directories are :ABSOLUTE. if (result.length() > 1 @@ -878,8 +833,8 @@ @Override public String writeToString() { final LispThread thread = LispThread.currentThread(); - boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); - boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); + final boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); + final boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); boolean useNamestring; String s = null; s = getNamestring(); @@ -901,7 +856,7 @@ } } } - } else { + } else { useNamestring = false; } StringBuilder sb = new StringBuilder(); @@ -923,41 +878,58 @@ sb.append('"'); } } else { - sb.append("#P("); - if (host != NIL) { - sb.append(":HOST "); - sb.append(host.writeToString()); - sb.append(' '); - } - if (device != NIL) { - sb.append(":DEVICE "); - sb.append(device.writeToString()); - sb.append(' '); - } - if (directory != NIL) { - sb.append(":DIRECTORY "); - sb.append(directory.writeToString()); - sb.append(" "); - } - if (name != NIL) { - sb.append(":NAME "); - sb.append(name.writeToString()); - sb.append(' '); - } - if (type != NIL) { - sb.append(":TYPE "); - sb.append(type.writeToString()); - sb.append(' '); - } - if (version != NIL) { - sb.append(":VERSION "); - sb.append(version.writeToString()); - sb.append(' '); - } - if (sb.charAt(sb.length() - 1) == ' ') { - sb.setLength(sb.length() - 1); + final SpecialBindingsMark mark = thread.markSpecialBindings(); + thread.bindSpecial(Symbol.PRINT_ESCAPE, T); + try { + final boolean ANSI_COMPATIBLE = true; + final String SPACE = " "; + if (ANSI_COMPATIBLE) { + sb.append("#P(\""); + } else { + sb.append("#P("); + + } + if (host != NIL) { + sb.append(":HOST "); + sb.append(host.writeToString()); + sb.append(SPACE); + } + if (device != NIL) { + sb.append(":DEVICE "); + sb.append(device.writeToString()); + sb.append(SPACE); + } + if (directory != NIL) { + sb.append(":DIRECTORY "); + sb.append(directory.writeToString()); + sb.append(SPACE); + } + if (name != NIL) { + sb.append(":NAME "); + sb.append(name.writeToString()); + sb.append(SPACE); + } + if (type != NIL) { + sb.append(":TYPE "); + sb.append(type.writeToString()); + sb.append(SPACE); + } + if (version != NIL) { + sb.append(":VERSION "); + sb.append(version.writeToString()); + sb.append(SPACE); + } + if (sb.charAt(sb.length() - 1) == ' ') { // XXX + sb.setLength(sb.length() - 1); + } + if (ANSI_COMPATIBLE) { + sb.append(')' + "\""); + } else { + sb.append(')'); + } + } finally { + thread.resetSpecialBindings(mark); } - sb.append(')'); } return sb.toString(); } @@ -1233,7 +1205,7 @@ namestring = file.getCanonicalPath(); } catch (IOException e) { Debug.trace("Failed to make a Pathname from " - + "'" + file + "'"); + + "." + file + "'"); return null; } return new Pathname(namestring); @@ -1302,17 +1274,22 @@ } final Pathname p; final boolean logical; + LispObject logicalHost = NIL; if (host != NIL) { if (host instanceof AbstractString) { - host = LogicalPathname.canonicalizeStringComponent((AbstractString) host); + logicalHost = LogicalPathname.canonicalizeStringComponent((AbstractString) host); + } + if (LOGICAL_PATHNAME_TRANSLATIONS.get(logicalHost) == null) { + // Not a defined logical pathname host -- A UNC path + //warning(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); + p = new Pathname(); + logical = false; + p.host = host; + } else { + p = new LogicalPathname(); + logical = true; + p.host = logicalHost; } - if (LOGICAL_PATHNAME_TRANSLATIONS.get(host) == null) { - // Not a defined logical pathname host. - error(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); - } - p = new LogicalPathname(); - logical = true; - p.host = host; p.device = Keyword.UNSPECIFIC; } else { p = new Pathname(); @@ -1375,6 +1352,7 @@ final int limit = s.length(); for (int i = 0; i < limit; i++) { char c = s.charAt(i); + // XXX '\\' should be illegal in all Pathnames at this point? if (c == '/' || c == '\\' && Utilities.isPlatformWindows) { error(new LispError("Invalid character #\\" + c + " in pathname component \"" + s Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/ShellCommand.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/ShellCommand.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/ShellCommand.java Thu Jul 15 18:06:43 2010 @@ -235,9 +235,13 @@ // run-shell-command command &key directory (output *standard-output*) // ### %run-shell-command command directory output => exit-code - private static final Primitive _RUN_SHELL_COMMAND = - new Primitive("%run-shell-command", PACKAGE_SYS, false) - { + private static final Primitive _RUN_SHELL_COMMAND = new pf_run_shell_command(); + private static class pf_run_shell_command extends Primitive { + pf_run_shell_command() { + super("%run-shell-command", PACKAGE_SYS, false, + "command directory output => exit-code"); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/clos.lisp Thu Jul 15 18:06:43 2010 @@ -209,11 +209,8 @@ (push-on-end (cadr olist) readers) (push-on-end `(setf ,(cadr olist)) writers)) (t - (push-on-end (car olist) non-std-options) + (push-on-end `(quote ,(car olist)) non-std-options) (push-on-end (cadr olist) non-std-options)))) -; (error 'program-error -; "invalid initialization argument ~S for slot named ~S" -; (car olist) name)) `(list :name ',name ,@(when initfunction @@ -259,10 +256,7 @@ (cdr option)))))) ((:documentation :report) (list (car option) `',(cadr option))) - (t (list (car option) `(quote ,(cdr option)))))) -; (error 'program-error -; :format-control "invalid DEFCLASS option ~S" -; :format-arguments (list (car option)))))) + (t (list `(quote ,(car option)) `(quote ,(cdr option)))))) (defun make-initfunction (initform) `(function (lambda () ,initform))) @@ -337,8 +331,7 @@ (readers ()) (writers ()) (allocation :instance) - (allocation-class nil) - &allow-other-keys) + (allocation-class nil)) (setf (slot-definition-name slot) name) (setf (slot-definition-initargs slot) initargs) (setf (slot-definition-initform slot) initform) @@ -2339,7 +2332,7 @@ (declare (ignore slot-names)) ;;TODO? (declare (ignore name initargs initform initfunction readers writers allocation)) ;;For built-in slots - (apply #'init-slot-definition slot args) + (apply #'init-slot-definition slot :allow-other-keys t args) ;;For user-defined slots (call-next-method)) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/precompiler.lisp Thu Jul 15 18:06:43 2010 @@ -788,9 +788,15 @@ (let ((*precompile-env* (make-environment *precompile-env*)) (operator (car form)) (locals (cadr form)) - ;; precompile (thus macro-expand) the body before inspecting it - ;; for the use of our locals and optimizing them away - (body (mapcar #'precompile1 (cddr form)))) + body) + ;; first augment the environment with the newly-defined local functions + ;; to shadow preexisting macro definitions with the same names + (dolist (local locals) + (environment-add-function-definition *precompile-env* + (car local) (cddr local))) + ;; then precompile (thus macro-expand) the body before inspecting it + ;; for the use of our locals and optimizing them away + (setq body (mapcar #'precompile1 (cddr form))) (dolist (local locals) (let* ((name (car local)) (used-p (find-use name body))) From mevenson at common-lisp.net Sat Jul 17 08:42:44 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 17 Jul 2010 04:42:44 -0400 Subject: [armedbear-cvs] r12808 - trunk/abcl Message-ID: Author: mevenson Date: Sat Jul 17 04:42:43 2010 New Revision: 12808 Log: Fix TAGS creation on win32 for long commandline limitations (Matt Sedon). Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sat Jul 17 04:42:43 2010 @@ -445,7 +445,9 @@ - + + + From mevenson at common-lisp.net Sat Jul 17 10:26:38 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 17 Jul 2010 06:26:38 -0400 Subject: [armedbear-cvs] r12810 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Jul 17 06:26:33 2010 New Revision: 12810 Log: PATHNAME without namestring now has a non-printable representation. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat Jul 17 06:26:33 2010 @@ -860,6 +860,7 @@ useNamestring = false; } StringBuilder sb = new StringBuilder(); + if (useNamestring) { if (printReadably || printEscape) { sb.append("#P\""); @@ -877,61 +878,45 @@ if (printReadably || printEscape) { sb.append('"'); } - } else { - final SpecialBindingsMark mark = thread.markSpecialBindings(); - thread.bindSpecial(Symbol.PRINT_ESCAPE, T); - try { - final boolean ANSI_COMPATIBLE = true; - final String SPACE = " "; - if (ANSI_COMPATIBLE) { - sb.append("#P(\""); - } else { - sb.append("#P("); + return sb.toString(); + } - } - if (host != NIL) { - sb.append(":HOST "); - sb.append(host.writeToString()); - sb.append(SPACE); - } - if (device != NIL) { - sb.append(":DEVICE "); - sb.append(device.writeToString()); - sb.append(SPACE); - } - if (directory != NIL) { - sb.append(":DIRECTORY "); - sb.append(directory.writeToString()); - sb.append(SPACE); - } - if (name != NIL) { - sb.append(":NAME "); - sb.append(name.writeToString()); - sb.append(SPACE); - } - if (type != NIL) { - sb.append(":TYPE "); - sb.append(type.writeToString()); - sb.append(SPACE); - } - if (version != NIL) { - sb.append(":VERSION "); - sb.append(version.writeToString()); - sb.append(SPACE); - } - if (sb.charAt(sb.length() - 1) == ' ') { // XXX - sb.setLength(sb.length() - 1); - } - if (ANSI_COMPATIBLE) { - sb.append(')' + "\""); - } else { - sb.append(')'); - } - } finally { - thread.resetSpecialBindings(mark); - } + sb.append("PATHNAME (with no namestring) "); + if (host != NIL) { + sb.append(":HOST "); + sb.append(host.writeToString()); + sb.append(" "); } - return sb.toString(); + if (device != NIL) { + sb.append(":DEVICE "); + sb.append(device.writeToString()); + sb.append(" "); + } + if (directory != NIL) { + sb.append(":DIRECTORY "); + sb.append(directory.writeToString()); + sb.append(" "); + } + if (name != NIL) { + sb.append(":NAME "); + sb.append(name.writeToString()); + sb.append(" "); + } + if (type != NIL) { + sb.append(":TYPE "); + sb.append(type.writeToString()); + sb.append(" "); + } + if (version != NIL) { + sb.append(":VERSION "); + sb.append(version.writeToString()); + sb.append(" "); + } + if (sb.charAt(sb.length() - 1) == ' ') { + sb.setLength(sb.length() - 1); + } + + return unreadableString(sb.toString()); } // A logical host is represented as the string that names it. // (defvar *logical-pathname-translations* (make-hash-table :test 'equal)) Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Sat Jul 17 06:26:33 2010 @@ -534,11 +534,12 @@ public LispObject readPathname(ReadtableAccessor rta) { LispObject obj = read(true, NIL, false, LispThread.currentThread(), rta); - if (obj instanceof AbstractString) + if (obj instanceof AbstractString) { return Pathname.parseNamestring((AbstractString)obj); + } if (obj.listp()) return Pathname.makePathname(obj); - return error(new TypeError("#p requires a string or list argument.")); + return error(new TypeError("#p requires a string argument.")); } public LispObject readSymbol() { From mevenson at common-lisp.net Sat Jul 17 10:26:39 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 17 Jul 2010 06:26:39 -0400 Subject: [armedbear-cvs] r12809 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Jul 17 06:26:26 2010 New Revision: 12809 Log: Honor *PRINT-READABLY* by throwing PRINT-NOT-READABLE for "#<". Previously, if *PRINT-READABLY* was non-NIL, a string containing "#<" would be output without signalling a PRINT-NOT-READABLE condition as required by ANSI. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/print.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat Jul 17 06:26:26 2010 @@ -890,7 +890,16 @@ out = Symbol.STANDARD_OUTPUT.symbolValue(); else out = second; - checkStream(out)._writeString(first.writeToString()); + String output = first.writeToString(); + if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL + && output.contains("#<")) { + LispObject args = NIL; + args = args.push(first); + args = args.push(Keyword.OBJECT); + args = args.nreverse(); + return error(new PrintNotReadable(args)); + } + checkStream(out)._writeString(output); return first; } }; Modified: trunk/abcl/src/org/armedbear/lisp/print.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/print.lisp Sat Jul 17 06:26:26 2010 @@ -280,6 +280,10 @@ (symbol-package x)))) (defun %print-object (object stream) + (when (and *print-readably* + (typep object 'string) + (search "#<" object)) + (error 'print-not-readable :object object)) (if *print-pretty* (xp::output-pretty-object object stream) (output-ugly-object object stream))) From mevenson at common-lisp.net Sat Jul 17 12:03:59 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 17 Jul 2010 08:03:59 -0400 Subject: [armedbear-cvs] r12811 - trunk/abcl/test/lisp/ansi Message-ID: Author: mevenson Date: Sat Jul 17 08:03:55 2010 New Revision: 12811 Log: Re-implement clean for ANSI tests in Lisp to work under Windows. Thanks to Matt Sedon. Modified: trunk/abcl/test/lisp/ansi/package.lisp Modified: trunk/abcl/test/lisp/ansi/package.lisp ============================================================================== --- trunk/abcl/test/lisp/ansi/package.lisp (original) +++ trunk/abcl/test/lisp/ansi/package.lisp Sat Jul 17 08:03:55 2010 @@ -32,13 +32,22 @@ (format t "---> ~A begins.~%" message) (format t "Invoking ABCL hosted on ~A ~A.~%" (software-type) (software-version)) - (if (find :unix *features*) - (run-shell-command "cd ~A; make clean" ansi-tests-directory) - ;; XXX -- what to invoke on win32? Untested: - (run-shell-command - (format nil "~A~%~A" - (format nil "cd ~A" *ansi-tests-directory*) - (format nil "erase *.cls *.abcl")))) + ;; Do what 'make clean' would do from the GCL ANSI tests, + ;; so we don't have to hunt for 'make' on win32. + (mapcar #'delete-file + (append (directory (format nil "~A/*.cls" *default-pathname-defaults*)) + (directory (format nil "~A/*.abcl" *default-pathname-defaults*)) + (directory (format nil "~A/scratch/*" *default-pathname-defaults*)) + (mapcar (lambda(x) (format nil "~A/~A" *default-pathname-defaults* x)) + '("scratch/" + "scratch.txt" "foo.txt" "foo.lsp" + "foo.dat" + "tmp.txt" "tmp.dat" "tmp2.dat" + "temp.dat" "out.class" + "file-that-was-renamed.txt" + "compile-file-test-lp.lsp" + "compile-file-test-lp.out" + "ldtest.lsp")))) (time (load boot-file)) (format t "<--- ~A ends.~%" message)) (file-error (e) From ehuelsmann at common-lisp.net Mon Jul 19 18:00:09 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 19 Jul 2010 14:00:09 -0400 Subject: [armedbear-cvs] r12812 - branches/0.21.x Message-ID: Author: ehuelsmann Date: Mon Jul 19 14:00:08 2010 New Revision: 12812 Log: Create 0.21 release maintenance branch. Added: branches/0.21.x/ - copied from r12811, /trunk/ From astalla at common-lisp.net Mon Jul 19 21:04:24 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 19 Jul 2010 17:04:24 -0400 Subject: [armedbear-cvs] r12813 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Jul 19 17:04:23 2010 New Revision: 12813 Log: Java interop, small improvement: the first argument to jnew can now also be a jclass reference. Modified: trunk/abcl/src/org/armedbear/lisp/Java.java 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 Mon Jul 19 17:04:23 2010 @@ -523,7 +523,19 @@ if(classRef instanceof AbstractString) { constructor = findConstructor(javaClass(classRef), args); } else { - constructor = (Constructor) JavaObject.getObject(classRef); + Object object = JavaObject.getObject(classRef); + if(object instanceof Constructor) { + constructor = (Constructor) object; + } else if(object instanceof Class) { + constructor = findConstructor((Class) object, args); + } else { + return type_error(classRef, + list(Symbol.OR, + list(Symbol.JCLASS, + new SimpleString("java.lang.reflect.Constructor")), + list(Symbol.JCLASS, + new SimpleString("java.lang.Class")))); + } } Class[] argTypes = constructor.getParameterTypes(); Object[] initargs = new Object[args.length-1]; From astalla at common-lisp.net Tue Jul 20 18:36:45 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 20 Jul 2010 14:36:45 -0400 Subject: [armedbear-cvs] r12814 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Jul 20 14:36:44 2010 New Revision: 12814 Log: Fix for r12809: bind *print-readably* to NIL when printing conditions in the debugger to avoid Maximum error depth exceeded. Fix for r12813: Better error reporting. Modified: trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/debug.lisp 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 Tue Jul 20 14:36:44 2010 @@ -529,12 +529,7 @@ } else if(object instanceof Class) { constructor = findConstructor((Class) object, args); } else { - return type_error(classRef, - list(Symbol.OR, - list(Symbol.JCLASS, - new SimpleString("java.lang.reflect.Constructor")), - list(Symbol.JCLASS, - new SimpleString("java.lang.Class")))); + return error(new LispError(classRef.writeToString() + " is neither a Constructor nor a Class")); } } Class[] argTypes = constructor.getParameterTypes(); Modified: trunk/abcl/src/org/armedbear/lisp/debug.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/debug.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/debug.lisp Tue Jul 20 14:36:44 2010 @@ -85,7 +85,8 @@ (when condition (fresh-line *debug-io*) (with-standard-io-syntax - (let ((*print-structure* nil)) + (let ((*print-structure* nil) + (*print-readably* nil)) (when (and *load-truename* (streamp *load-stream*)) (simple-format *debug-io* "Error loading ~A at line ~D (offset ~D)~%" From astalla at common-lisp.net Tue Jul 20 21:04:41 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 20 Jul 2010 17:04:41 -0400 Subject: [armedbear-cvs] r12815 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Jul 20 17:04:41 2010 New Revision: 12815 Log: Fixed printing of certain conditions (e.g., type-errors) with unbound format-control. Modified: trunk/abcl/src/org/armedbear/lisp/Condition.java Modified: trunk/abcl/src/org/armedbear/lisp/Condition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Condition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Condition.java Tue Jul 20 17:04:41 2010 @@ -104,7 +104,7 @@ public final LispObject getFormatControl() { - return getInstanceSlotValue(Symbol.FORMAT_CONTROL); + return getInstanceSlotValue(Symbol.FORMAT_CONTROL); } public final void setFormatControl(LispObject formatControl) @@ -135,7 +135,8 @@ */ public String getMessage() { - return getFormatControl().toString(); + LispObject formatControl = getFormatControl(); + return formatControl != UNBOUND_VALUE ? formatControl.writeToString() : null; } @Override From mevenson at common-lisp.net Wed Jul 21 07:39:39 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 21 Jul 2010 03:39:39 -0400 Subject: [armedbear-cvs] r12816 - trunk/abcl/test/lisp/ansi Message-ID: Author: mevenson Date: Wed Jul 21 03:39:38 2010 New Revision: 12816 Log: Upgrade finding test results database for ASDF2. Modified: trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp Modified: trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp ============================================================================== --- trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp (original) +++ trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp Wed Jul 21 03:39:38 2010 @@ -74,7 +74,9 @@ (getf `(doit ,*doit* compileit ,*compileit*) test)) (defvar *default-database-file* - (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*))) + (if (find :asdf2 *features*) + (asdf:system-relative-pathname :ansi-compiled "test/lisp/ansi/ansi-test-failures") + (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*))) (defun parse (&optional (file *default-database-file*)) (format t "Parsing test report database from ~A~%" *default-database-file*) From ehuelsmann at common-lisp.net Thu Jul 22 18:05:07 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 22 Jul 2010 14:05:07 -0400 Subject: [armedbear-cvs] r12817 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 22 14:05:06 2010 New Revision: 12817 Log: With 0.21.x being branched, update the version of trunk. Modified: trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Thu Jul 22 14:05:06 2010 @@ -41,9 +41,9 @@ public static String getVersion() { - return "0.21.0-dev"; + return "0.22.0-dev"; } - + public static void main(String args[]) { System.out.println(Version.getVersion()); } From ehuelsmann at common-lisp.net Thu Jul 22 18:12:06 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 22 Jul 2010 14:12:06 -0400 Subject: [armedbear-cvs] r12818 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 22 14:12:05 2010 New Revision: 12818 Log: Upgrade ASDF to 2.004, as per request of their developer(s). Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Thu Jul 22 14:12:05 2010 @@ -70,7 +70,7 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105. + (subseq "VERSION:2.004" (1+ (length "VERSION")))) ; NB: same as 2.111. (existing-asdf (find-package :asdf)) (vername '#:*asdf-version*) (versym (and existing-asdf @@ -727,8 +727,12 @@ #+clisp (defun get-uid () (posix:uid)) #+sbcl (defun get-uid () (sb-unix:unix-getuid)) #+cmu (defun get-uid () (unix:unix-getuid)) -#+ecl (ffi:clines "#include " "#include ") -#+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t)) +#+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) + '(ffi:clines "#include " "#include ")) +#+ecl (defun get-uid () + #.(cl:if (cl:< ext:+ecl-version-number+ 100601) + '(ffi:c-inline () () :int "getuid()" :one-liner t) + '(ext::getuid))) #+allegro (defun get-uid () (excl.osi:getuid)) #-(or cmu sbcl clisp allegro ecl) (defun get-uid () @@ -1073,6 +1077,17 @@ (defun system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) +(defun clear-system (name) + "Clear the entry for a system in the database of systems previously loaded. +Note that this does NOT in any way cause the code of the system to be unloaded." + ;; There is no "unload" operation in Common Lisp, and a general such operation + ;; cannot be portably written, considering how much CL relies on side-effects + ;; of global data structures. + ;; Note that this does a setf gethash instead of a remhash + ;; this way there remains a hint in the *defined-systems* table + ;; that the system was loaded at some point. + (setf (gethash (coerce-name name) *defined-systems*) nil)) + (defun map-systems (fn) "Apply FN to each defined system. @@ -2395,6 +2410,7 @@ :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc :java-1.4 :java-1.5 :java-1.6 :java-1.7)) + (defun lisp-version-string () (let ((s (lisp-implementation-version))) (declare (ignorable s)) @@ -2410,6 +2426,7 @@ (:-ics "8") (:+ics "")) (if (member :64bit *features*) "-64bit" "")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) #+clisp (subseq s 0 (position #\space s)) #+clozure (format nil "~d.~d-fasl~d" ccl::*openmcl-major-version* @@ -2424,8 +2441,7 @@ #+gcl (subseq s (1+ (position #\space s))) #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")) - ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant - #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version #+(or cormanlisp mcl sbcl scl) s #-(or allegro armedbear clisp clozure cmu cormanlisp digitool ecl gcl lispworks mcl sbcl scl) s)) @@ -2510,7 +2526,7 @@ `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) - (list #p"/etc/")))) + (list #p"/etc/common-lisp/")))) (defun in-first-directory (dirs x) (loop :for dir :in dirs :thereis (and dir (ignore-errors @@ -2957,7 +2973,7 @@ :defaults x)) (defun delete-file-if-exists (x) - (when (probe-file x) + (when (and x (probe-file x)) (delete-file x))) (defun compile-file* (input-file &rest keys &key &allow-other-keys) @@ -3354,14 +3370,18 @@ (defun initialize-source-registry (&optional parameter) (setf (source-registry) (compute-source-registry parameter))) -;; checks an initial variable to see whether the state is initialized +;; Checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in ;; the latter, initialize. ASDF will call this function at the start -;; of (asdf:find-system). -(defun ensure-source-registry () +;; of (asdf:find-system) to make sure the source registry is initialized. +;; However, it will do so *without* a parameter, at which point it +;; will be too late to provide a parameter to this function, though +;; you may override the configuration explicitly by calling +;; initialize-source-registry directly with your parameter. +(defun ensure-source-registry (&optional parameter) (if (source-registry-initialized-p) (source-registry) - (initialize-source-registry))) + (initialize-source-registry parameter))) (defun sysdef-source-registry-search (system) (ensure-source-registry) From ehuelsmann at common-lisp.net Thu Jul 22 18:13:23 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 22 Jul 2010 14:13:23 -0400 Subject: [armedbear-cvs] r12819 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 22 14:13:22 2010 New Revision: 12819 Log: Remove to-be-removed-by-0.22 deprecated symbols, now that we are 0.22. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/threads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Thu Jul 22 14:13:22 2010 @@ -1120,19 +1120,6 @@ }; - static { - //FIXME: this block has been added for pre-0.16 compatibility - // and can be removed the latest at release 0.22 - PACKAGE_EXT.export(intern("MAKE-THREAD", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("THREADP", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("THREAD-ALIVE-P", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("THREAD-NAME", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("MAPCAR-THREADS", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("DESTROY-THREAD", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("INTERRUPT-THREAD", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("CURRENT-THREAD", PACKAGE_THREADS)); - } - // ### use-fast-calls private static final Primitive USE_FAST_CALLS = new Primitive("use-fast-calls", PACKAGE_SYS, true) 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 Jul 22 14:13:22 2010 @@ -345,16 +345,6 @@ (export '(make-thread-lock thread-lock thread-unlock with-thread-lock)) (export '(make-mutex get-mutex release-mutex with-mutex)) -(progn - ;; block to be removed at 0.22 - ;; It exists solely for pre-0.17 compatibility - ;; FIXME 0.22 - (in-package "EXTENSIONS") - (export '(mailbox-send mailbox-empty-p mailbox-read mailbox-peek)) - (export '(make-thread-lock thread-lock thread-unlock with-thread-lock)) - (export '(with-mutex make-mutex get-mutex release-mutex))) - -;; end of 0.22 block (in-package "EXTENSIONS") Modified: trunk/abcl/src/org/armedbear/lisp/threads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/threads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/threads.lisp Thu Jul 22 14:13:22 2010 @@ -1,6 +1,6 @@ ;;; threads.lisp ;;; -;;; Copyright (C) 2009 Erik Huelsmann +;;; Copyright (C) 2009-2010 Erik Huelsmann ;;; ;;; $Id$ ;;; @@ -142,9 +142,3 @@ (synchronized-on ,glock , at body)))) -(defun thread-lock (lock) - "Deprecated; due for removal in 0.22" - (declare (ignore lock))) -(defun thread-unlock (lock) - "Deprecated; due for removal in 0.22" - (declare (ignore lock))) From ehuelsmann at common-lisp.net Thu Jul 22 18:21:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 22 Jul 2010 14:21:35 -0400 Subject: [armedbear-cvs] r12820 - branches/0.21.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 22 14:21:34 2010 New Revision: 12820 Log: Backport part of r12814 which applies to r12809. Note: the remainder of the r12814 relates to code not in the branch. Modified: branches/0.21.x/abcl/src/org/armedbear/lisp/debug.lisp Modified: branches/0.21.x/abcl/src/org/armedbear/lisp/debug.lisp ============================================================================== --- branches/0.21.x/abcl/src/org/armedbear/lisp/debug.lisp (original) +++ branches/0.21.x/abcl/src/org/armedbear/lisp/debug.lisp Thu Jul 22 14:21:34 2010 @@ -85,7 +85,8 @@ (when condition (fresh-line *debug-io*) (with-standard-io-syntax - (let ((*print-structure* nil)) + (let ((*print-structure* nil) + (*print-readably* nil)) (when (and *load-truename* (streamp *load-stream*)) (simple-format *debug-io* "Error loading ~A at line ~D (offset ~D)~%" From ehuelsmann at common-lisp.net Thu Jul 22 18:34:10 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 22 Jul 2010 14:34:10 -0400 Subject: [armedbear-cvs] r12821 - branches/0.21.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jul 22 14:34:09 2010 New Revision: 12821 Log: Backport r12815 (printing of conditions with unbound format-control). Modified: branches/0.21.x/abcl/src/org/armedbear/lisp/Condition.java Modified: branches/0.21.x/abcl/src/org/armedbear/lisp/Condition.java ============================================================================== --- branches/0.21.x/abcl/src/org/armedbear/lisp/Condition.java (original) +++ branches/0.21.x/abcl/src/org/armedbear/lisp/Condition.java Thu Jul 22 14:34:09 2010 @@ -104,7 +104,7 @@ public final LispObject getFormatControl() { - return getInstanceSlotValue(Symbol.FORMAT_CONTROL); + return getInstanceSlotValue(Symbol.FORMAT_CONTROL); } public final void setFormatControl(LispObject formatControl) @@ -135,7 +135,8 @@ */ public String getMessage() { - return getFormatControl().toString(); + LispObject formatControl = getFormatControl(); + return formatControl != UNBOUND_VALUE ? formatControl.writeToString() : null; } @Override From ehuelsmann at common-lisp.net Sat Jul 24 19:05:01 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 24 Jul 2010 15:05:01 -0400 Subject: [armedbear-cvs] r12822 - in tags/0.21.0: . abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 24 15:04:59 2010 New Revision: 12822 Log: Tag 0.21.0. Added: tags/0.21.0/ - copied from r12821, /branches/0.21.x/ Modified: tags/0.21.0/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.21.0/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.21.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.21.0/abcl/src/org/armedbear/lisp/Version.java Sat Jul 24 15:04:59 2010 @@ -41,9 +41,9 @@ public static String getVersion() { - return "0.21.0-dev"; + return "0.21.0"; } - + public static void main(String args[]) { System.out.println(Version.getVersion()); } From ehuelsmann at common-lisp.net Sat Jul 24 19:05:52 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 24 Jul 2010 15:05:52 -0400 Subject: [armedbear-cvs] r12823 - branches/0.21.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 24 15:05:51 2010 New Revision: 12823 Log: Bump branch version to 0.21.1-dev, now that 0.21.0 has been tagged. Modified: branches/0.21.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.21.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.21.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.21.x/abcl/src/org/armedbear/lisp/Version.java Sat Jul 24 15:05:51 2010 @@ -41,9 +41,9 @@ public static String getVersion() { - return "0.21.0-dev"; + return "0.21.1-dev"; } - + public static void main(String args[]) { System.out.println(Version.getVersion()); } From ehuelsmann at common-lisp.net Sat Jul 24 20:27:07 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 24 Jul 2010 16:27:07 -0400 Subject: [armedbear-cvs] r12824 - public_html/releases Message-ID: Author: ehuelsmann Date: Sat Jul 24 16:27:02 2010 New Revision: 12824 Log: Add 0.21.0 release files. Added: public_html/releases/abcl-bin-0.21.0.tar.gz (contents, props changed) public_html/releases/abcl-bin-0.21.0.tar.gz.asc public_html/releases/abcl-bin-0.21.0.zip (contents, props changed) public_html/releases/abcl-bin-0.21.0.zip.asc public_html/releases/abcl-src-0.21.0.tar.gz (contents, props changed) public_html/releases/abcl-src-0.21.0.tar.gz.asc public_html/releases/abcl-src-0.21.0.zip (contents, props changed) public_html/releases/abcl-src-0.21.0.zip.asc Added: public_html/releases/abcl-bin-0.21.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-bin-0.21.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.21.0.tar.gz.asc Sat Jul 24 16:27:02 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkxLSG0ACgkQi5O0Epaz9TlCDACfabG+X8Vyo0nGahTxzBcfqOlv +fwsAniTKsJTqtlbQWtFrMLoI38sqg0W6 +=NDnj +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-bin-0.21.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-bin-0.21.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.21.0.zip.asc Sat Jul 24 16:27:02 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkxLSHoACgkQi5O0Epaz9TkNLACfUCxdpEadyCxYX6MoufrXKTba +DaoAnjo1bBrInB/93XLnd5BD1pY7gIpY +=jdgf +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.21.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.21.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.21.0.tar.gz.asc Sat Jul 24 16:27:02 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkxLSI0ACgkQi5O0Epaz9TlfBACfbLK49HamxvlUvcFXS5n8jIOk +U4EAniaOavj6bOeyNzjv806NvFggkKXs +=pBxm +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.21.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.21.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.21.0.zip.asc Sat Jul 24 16:27:02 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkxLSJQACgkQi5O0Epaz9TlaawCeI5qpYziHKCuPhDFohPN8rNaY +gU4An2MTrg+WV2xB8xpGT9pCbMnAChVG +=qAbA +-----END PGP SIGNATURE----- From vvoutilainen at common-lisp.net Sun Jul 25 17:47:23 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 25 Jul 2010 13:47:23 -0400 Subject: [armedbear-cvs] r12825 - public_html Message-ID: Author: vvoutilainen Date: Sun Jul 25 13:47:21 2010 New Revision: 12825 Log: Point to the newest release notes. Modified: public_html/left-menu Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Sun Jul 25 13:47:21 2010 @@ -1,7 +1,7 @@
Project page
Testimonials
-Release notes
+Release notes
Paid support
From vvoutilainen at common-lisp.net Sun Jul 25 19:09:14 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 25 Jul 2010 15:09:14 -0400 Subject: [armedbear-cvs] r12826 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Jul 25 15:09:13 2010 New Revision: 12826 Log: DocString annotation support, for generating DOCUMENTATION, and later Javadoc from the same data. Also includes TAGS support for the DocString annotations. Patch by Matt Seddon. Added: trunk/abcl/src/org/armedbear/lisp/DocString.java Modified: trunk/abcl/build.xml trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java trunk/abcl/src/org/armedbear/lisp/Function.java trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/LispThread.java trunk/abcl/src/org/armedbear/lisp/Operator.java trunk/abcl/src/org/armedbear/lisp/Primitive.java trunk/abcl/src/org/armedbear/lisp/logorc2.java trunk/abcl/src/org/armedbear/lisp/package_error_package.java Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sun Jul 25 15:09:13 2010 @@ -449,6 +449,7 @@ + Added: trunk/abcl/src/org/armedbear/lisp/DocString.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/DocString.java Sun Jul 25 15:09:13 2010 @@ -0,0 +1,50 @@ +/* + * DocString.java + * + * Copyright (C) 2010 Matt Seddon + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ +package org.armedbear.lisp; + +import java.lang.annotation.*; + +/** + * An annotation type to expose documentation to ABCL. + * Note: the TAGS ant target also pulls information from here. It + * expects name to be the first item in the DocString declaration, + * and not broken onto multiple lines. + */ + at Retention(RetentionPolicy.RUNTIME) +public @interface DocString { + /** The lisp name. */ + public String name() default ""; + /** The arguments. */ + public String args() default ""; + /** The documentation string. */ + public String doc() default ""; +} Modified: trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Sun Jul 25 15:09:13 2010 @@ -76,7 +76,7 @@ return unreadableString(sb.toString()); } - // ### make-forward-referenced-class + @DocString(name="make-forward-referenced=class") private static final Primitive MAKE_FORWARD_REFERENCED_CLASS = new Primitive("make-forward-referenced-class", PACKAGE_SYS, true) { Modified: trunk/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Function.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Function.java Sun Jul 25 15:09:13 2010 @@ -53,7 +53,14 @@ public Function(String name) { + this(name, (String)null); + } + + public Function(String name, String arglist) + { this(); + if(arglist != null) + setLambdaList(new SimpleString(arglist)); if (name != null) { Symbol symbol = Symbol.addFunction(name.toUpperCase(), this); if (cold) @@ -62,14 +69,14 @@ } } + public Function(Symbol symbol) + { + this(symbol, null, null); + } + public Function(Symbol symbol, String arglist) { - this(); - symbol.setSymbolFunction(this); - if (cold) - symbol.setBuiltInFunction(true); - setLambdaName(symbol); - setLambdaList(new SimpleString(arglist)); + this(symbol, arglist, null); } public Function(Symbol symbol, String arglist, String docstring) @@ -79,17 +86,11 @@ if (cold) symbol.setBuiltInFunction(true); setLambdaName(symbol); - setLambdaList(new SimpleString(arglist)); - if (docstring != null) { + if(arglist != null) + setLambdaList(new SimpleString(arglist)); + if (docstring != null) symbol.setDocumentation(Symbol.FUNCTION, new SimpleString(docstring)); - } - } - - public Function(String name, String arglist) - { - this(name); - setLambdaList(new SimpleString(arglist)); } public Function(String name, Package pkg) 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 Sun Jul 25 15:09:13 2010 @@ -60,11 +60,13 @@ } private static final Primitive ENSURE_JAVA_OBJECT = new pf_ensure_java_object(); + @DocString(name="ensure-java-object", args="obj", + doc="Ensures OBJ is wrapped in a JAVA-OBJECT, wrapping it if necessary.") private static final class pf_ensure_java_object extends Primitive { pf_ensure_java_object() { - super("ensure-java-object", PACKAGE_JAVA, true, "obj"); + super("ensure-java-object", PACKAGE_JAVA, true); } @Override @@ -73,14 +75,16 @@ } }; - // ### register-java-exception exception-name condition-symbol => T private static final Primitive REGISTER_JAVA_EXCEPTION = new pf_register_java_exception(); + @DocString(name="register-java-exception", // => T + args="exception-name condition-symbol", + doc="Registers the Java Throwable named by the symbol EXCEPTION-NAME as the condition " + + "designated by CONDITION-SYMBOL. Returns T if successful, NIL if not.") private static final class pf_register_java_exception extends Primitive { pf_register_java_exception() { - super("register-java-exception", PACKAGE_JAVA, true, - "exception-name condition-symbol"); + super("register-java-exception", PACKAGE_JAVA, true); } @Override @@ -98,14 +102,15 @@ } }; - // ### unregister-java-exception exception-name => T or NIL private static final Primitive UNREGISTER_JAVA_EXCEPTION = new pf_unregister_java_exception(); + @DocString(name="unregister-java-exception", args="exception-name", + doc="Unregisters the Java Throwable EXCEPTION-NAME previously registered" + + " by REGISTER-JAVA-EXCEPTION.") private static final class pf_unregister_java_exception extends Primitive { pf_unregister_java_exception() { - super("unregister-java-exception", PACKAGE_JAVA, true, - "exception-name"); + super("unregister-java-exception", PACKAGE_JAVA, true); } @Override @@ -129,15 +134,17 @@ return null; } - // ### jclass name-or-class-ref &optional class-loader => class-ref private static final Primitive JCLASS = new pf_jclass(); + @DocString(name="jclass", args="name-or-class-ref &optional class-loader", + doc="Returns a reference to the Java class designated by" + + " NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the" + + " class is resolved with respect to the given ClassLoader.") private static final class pf_jclass extends Primitive { pf_jclass() { - super(Symbol.JCLASS, "name-or-class-ref &optional class-loader", - "Returns a reference to the Java class designated by NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the class is resolved with respect to the given ClassLoader."); + super(Symbol.JCLASS); } @Override @@ -154,35 +161,6 @@ } }; - // ### jfield - retrieve or modify a field in a Java class or instance. - // - // Supported argument patterns: - // - // Case 1: class-ref field-name: - // to retrieve the value of a static field. - // - // Case 2: class-ref field-name instance-ref: - // to retrieve the value of a class field of the instance. - // - // Case 3: class-ref field-name primitive-value: - // to store primitive-value in a static field. - // - // Case 4: class-ref field-name instance-ref value: - // to store value in a class field of the instance. - // - // Case 5: class-ref field-name nil value: - // to store value in a static field (when value may be - // confused with an instance-ref). - // - // Case 6: field-name instance: - // to retrieve the value of a field of the instance. The - // class is derived from the instance. - // - // Case 7: field-name instance value: - // to store value in a field of the instance. The class is - // derived from the instance. - // - static final LispObject jfield(Primitive fun, LispObject[] args, boolean translate) { @@ -258,14 +236,35 @@ return NIL; } - // ### jfield class-ref-or-field field-or-instance &optional instance value + private static final Primitive JFIELD = new pf_jfield(); + @DocString(name="jfield", + args="class-ref-or-field field-or-instance &optional instance value", + doc="Retrieves or modifies a field in a Java class or instance.\n\n"+ + "Supported argument patterns:\n\n"+ + " Case 1: class-ref field-name:\n"+ + " Retrieves the value of a static field.\n\n"+ + " Case 2: class-ref field-name instance-ref:\n"+ + " Retrieves the value of a class field of the instance.\n\n"+ + " Case 3: class-ref field-name primitive-value:\n"+ + " Stores a primitive-value in a static field.\n\n"+ + " Case 4: class-ref field-name instance-ref value:\n"+ + " Stores value in a class field of the instance.\n\n"+ + " Case 5: class-ref field-name nil value:\n"+ + " Stores value in a static field (when value may be\n"+ + " confused with an instance-ref).\n\n"+ + " Case 6: field-name instance:\n"+ + " Retrieves the value of a field of the instance. The\n"+ + " class is derived from the instance.\n\n"+ + " Case 7: field-name instance value:\n"+ + " Stores value in a field of the instance. The class is\n"+ + " derived from the instance.\n\n" + ) private static final class pf_jfield extends Primitive { pf_jfield() { - super("jfield", PACKAGE_JAVA, true, - "class-ref-or-field field-or-instance &optional instance value"); + super("jfield", PACKAGE_JAVA, true); } @Override @@ -275,14 +274,35 @@ } }; - // ### jfield-raw - retrieve or modify a field in a Java class or instance. private static final Primitive JFIELD_RAW = new pf_jfield_raw(); + @DocString(name="jfield", + args="class-ref-or-field field-or-instance &optional instance value", + doc="Retrieves or modifies a field in a Java class or instance. Does not\n"+ + "attempt to coerce its value or the result into a Lisp object.\n\n"+ + "Supported argument patterns:\n\n"+ + " Case 1: class-ref field-name:\n"+ + " Retrieves the value of a static field.\n\n"+ + " Case 2: class-ref field-name instance-ref:\n"+ + " Retrieves the value of a class field of the instance.\n\n"+ + " Case 3: class-ref field-name primitive-value:\n"+ + " Stores a primitive-value in a static field.\n\n"+ + " Case 4: class-ref field-name instance-ref value:\n"+ + " Stores value in a class field of the instance.\n\n"+ + " Case 5: class-ref field-name nil value:\n"+ + " Stores value in a static field (when value may be\n"+ + " confused with an instance-ref).\n\n"+ + " Case 6: field-name instance:\n"+ + " Retrieves the value of a field of the instance. The\n"+ + " class is derived from the instance.\n\n"+ + " Case 7: field-name instance value:\n"+ + " Stores value in a field of the instance. The class is\n"+ + " derived from the instance.\n\n" + ) private static final class pf_jfield_raw extends Primitive { pf_jfield_raw() { - super("jfield-raw", PACKAGE_JAVA, true, - "class-ref-or-field field-or-instance &optional instance value"); + super("jfield-raw", PACKAGE_JAVA, true); } @Override @@ -292,14 +312,15 @@ } }; - // ### jconstructor class-ref &rest parameter-class-refs private static final Primitive JCONSTRUCTOR = new pf_jconstructor(); + @DocString(name="jconstructor", args="class-ref &rest parameter-class-refs", + doc="Returns a reference to the Java constructor of CLASS-REF with the" + + " given PARAMETER-CLASS-REFS.") private static final class pf_jconstructor extends Primitive { pf_jconstructor() { - super("jconstructor", PACKAGE_JAVA, true, - "class-ref &rest parameter-class-refs"); + super("jconstructor", PACKAGE_JAVA, true); } @Override @@ -342,14 +363,16 @@ } }; - // ### jmethod class-ref name &rest parameter-class-refs private static final Primitive JMETHOD = new pf_jmethod(); + + @DocString(name="jmethod", args="class-ref method-name &rest parameter-class-refs", + doc="Returns a reference to the Java method METHOD-NAME of CLASS-REF with the" + + " given PARAMETER-CLASS-REFS.") private static final class pf_jmethod extends Primitive { pf_jmethod() { - super("jmethod", PACKAGE_JAVA, true, - "class-ref name &rest parameter-class-refs"); + super("jmethod", PACKAGE_JAVA, true); } @Override @@ -470,13 +493,14 @@ return NIL; } - // ### jstatic method class &rest args private static final Primitive JSTATIC = new pf_jstatic(); + @DocString(name="jstatic", args="method class &rest args", + doc="Invokes the static method METHOD on class CLASS with ARGS.") private static final class pf_jstatic extends Primitive { pf_jstatic() { - super("jstatic", PACKAGE_JAVA, true, "method class &rest args"); + super("jstatic", PACKAGE_JAVA, true); } @Override @@ -486,14 +510,15 @@ } }; - // ### jstatic-raw method class &rest args private static final Primitive JSTATIC_RAW = new pf_jstatic_raw(); + @DocString(name="jstatic-raw", args="method class &rest args", + doc="Invokes the static method METHOD on class CLASS with ARGS. Does not "+ + "attempt to coerce the arguments or result into a Lisp object.") private static final class pf_jstatic_raw extends Primitive { pf_jstatic_raw() { - super("jstatic-raw", PACKAGE_JAVA, true, - "method class &rest args"); + super("jstatic-raw", PACKAGE_JAVA, true); } @Override @@ -503,13 +528,14 @@ } }; - // ### jnew constructor &rest args private static final Primitive JNEW = new pf_jnew(); + @DocString(name="jnew", args="constructor &rest args", + doc="Invokes the Java constructor CONSTRUCTOR with the arguments ARGS.") private static final class pf_jnew extends Primitive { pf_jnew() { - super("jnew", PACKAGE_JAVA, true, "constructor &rest args"); + super("jnew", PACKAGE_JAVA, true); } @Override @@ -566,14 +592,15 @@ } }; - // ### jnew-array element-type &rest dimensions private static final Primitive JNEW_ARRAY = new pf_jnew_array(); + @DocString(name="jnew-array", args="element-type &rest dimensions", + doc="Creates a new Java array of type ELEMENT-TYPE, with the given" + + " DIMENSIONS.") private static final class pf_jnew_array extends Primitive { pf_jnew_array() { - super("jnew-array", PACKAGE_JAVA, true, - "element-type &rest dimensions"); + super("jnew-array", PACKAGE_JAVA, true); } @Override @@ -624,14 +651,15 @@ return NIL; } - // ### jarray-ref java-array &rest indices private static final Primitive JARRAY_REF = new pf_jarray_ref(); + @DocString(name="jarray-ref", args="java-array &rest indices", + doc="Dereferences the Java array JAVA-ARRAY using the given INDICIES, " + + "coercing the result into a Lisp object, if possible.") private static final class pf_jarray_ref extends Primitive { pf_jarray_ref() { - super("jarray-ref", PACKAGE_JAVA, true, - "java-array &rest indices"); + super("jarray-ref", PACKAGE_JAVA, true); } @Override @@ -641,14 +669,15 @@ } }; - // ### jarray-ref-raw java-array &rest indices private static final Primitive JARRAY_REF_RAW = new pf_jarray_ref_raw(); + @DocString(name="jarray-ref-raw", args="java-array &rest indices", + doc="Dereference the Java array JAVA-ARRAY using the given INDICIES. " + + "Does not attempt to coerce the result into a Lisp object.") private static final class pf_jarray_ref_raw extends Primitive { pf_jarray_ref_raw() { - super("jarray-ref-raw", PACKAGE_JAVA, true, - "java-array &rest indices"); + super("jarray-ref-raw", PACKAGE_JAVA, true); } @Override @@ -658,14 +687,14 @@ } }; - // ### jarray-set java-array new-value &rest indices private static final Primitive JARRAY_SET = new pf_jarray_set(); + @DocString(name="jarray-set", args="java-array new-value &rest indices", + doc="Stores NEW-VALUE at the given index in JAVA-ARRAY.") private static final class pf_jarray_set extends Primitive { pf_jarray_set() { - super("jarray-set", PACKAGE_JAVA, true, - "java-array new-value &rest indices"); + super("jarray-set", PACKAGE_JAVA, true); } @Override @@ -698,14 +727,16 @@ } }; - // ### jcall method instance &rest args /** Calls makeLispObject() to convert the result to an appropriate Lisp type. */ private static final Primitive JCALL = new pf_jcall(); + @DocString(name="jcall", args="method-ref instance &rest args", + doc="Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS," + + " coercing the result into a Lisp object, if possible.") private static final class pf_jcall extends Primitive { pf_jcall() { - super(Symbol.JCALL, "method-ref instance &rest args"); + super(Symbol.JCALL); } @Override @@ -715,17 +746,19 @@ } }; - // ### jcall-raw method instance &rest args /** * Does no type conversion. The result of the call is simply wrapped in a * JavaObject. */ private static final Primitive JCALL_RAW = new pf_jcall_raw(); + @DocString(name="jcall-raw", args="method-ref instance &rest args", + doc="Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS." + + " Does not attempt to coerce the result into a Lisp object.") private static final class pf_jcall_raw extends Primitive { pf_jcall_raw() { - super(Symbol.JCALL_RAW, "method-ref instance &rest args"); + super(Symbol.JCALL_RAW); } @Override @@ -983,14 +1016,17 @@ } } - // ### make-immediate-object object &optional type private static final Primitive MAKE_IMMEDIATE_OBJECT = new pf_make_immediate_object(); + @DocString(name="make-immediate-object", args="object &optional type", + doc="Attempts to coerce a given Lisp object into a java-object of the\n"+ + "given type. If type is not provided, works as jobject-lisp-value.\n"+ + "Currently, type may be :BOOLEAN, treating the object as a truth value,\n"+ + "or :REF, which returns Java null if NIL is provided.") private static final class pf_make_immediate_object extends Primitive { pf_make_immediate_object() { - super("make-immediate-object", PACKAGE_JAVA, true, - "object &optional type"); + super("make-immediate-object", PACKAGE_JAVA, true); } @Override @@ -1019,13 +1055,14 @@ } }; - // ### java-object-p private static final Primitive JAVA_OBJECT_P = new pf_java_object_p(); + @DocString(name="java-object-p", args="object", + doc="Returns T if OBJECT is a JAVA-OBJECT.") private static final class pf_java_object_p extends Primitive { pf_java_object_p() { - super("java-object-p", PACKAGE_JAVA, true, "object"); + super("java-object-p", PACKAGE_JAVA, true); } @Override @@ -1035,8 +1072,9 @@ } }; - // ### jobject-lisp-value java-object private static final Primitive JOBJECT_LISP_VALUE = new pf_jobject_lisp_value(); + @DocString(name="jobject-lisp-value", args="java-object", + doc="Attempts to coerce JAVA-OBJECT into a Lisp object.") private static final class pf_jobject_lisp_value extends Primitive { pf_jobject_lisp_value() @@ -1051,13 +1089,15 @@ } }; - // ### jcoerce java-object intended-class private static final Primitive JCOERCE = new pf_jcoerce(); + @DocString(name="jcoerce", args="object intended-class", + doc="Attempts to coerce OBJECT into a JavaObject of class INTENDED-CLASS." + + " Raises a TYPE-ERROR if no conversion is possible.") private static final class pf_jcoerce extends Primitive { pf_jcoerce() { - super("jcoerce", PACKAGE_JAVA, true, "java-object intended-class"); + super("jcoerce", PACKAGE_JAVA, true); } @Override @@ -1073,8 +1113,10 @@ } }; - // ### %jget-property-value java-object property-name private static final Primitive JGET_PROPERTY_VALUE = new pf__jget_property_value(); + @DocString(name="%jget-propety-value", args="java-object property-name", + doc="Gets a JavaBeans property on JAVA-OBJECT.\n" + + "SYSTEM-INTERNAL: Use jproperty-value instead.") private static final class pf__jget_property_value extends Primitive { pf__jget_property_value() @@ -1102,8 +1144,10 @@ } }; - // ### %jset-property-value java-object property-name value private static final Primitive JSET_PROPERTY_VALUE = new pf__jset_property_value(); + @DocString(name="%jset-propety-value", args="java-object property-name value", + doc="Sets a JavaBean property on JAVA-OBJECT.\n" + + "SYSTEM-INTERNAL: Use (setf jproperty-value) instead.") private static final class pf__jset_property_value extends Primitive { pf__jset_property_value() @@ -1138,15 +1182,15 @@ } }; - - // ### jrun-exception-protected closure private static final Primitive JRUN_EXCEPTION_PROTECTED = new pf_jrun_exception_protection(); + @DocString(name="jrun-exception-protected", args="closure", + doc="Invokes the function CLOSURE and returns the result. "+ + "Signals an error if stack or heap exhaustion occurs.") private static final class pf_jrun_exception_protection extends Primitive { pf_jrun_exception_protection() { - super("jrun-exception-protected", PACKAGE_JAVA, true, - "closure"); + super("jrun-exception-protected", PACKAGE_JAVA, true); } @Override Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Jul 25 15:09:13 2010 @@ -89,7 +89,7 @@ Packages.createPackage("SEQUENCE"); - // ### nil + @DocString(name="nil") public static final LispObject NIL = Nil.NIL; // We need NIL before we can call usePackage(). @@ -261,7 +261,7 @@ return thread.setValues(form, NIL); } - // ### interactive-eval + @DocString(name="interactive-eval") private static final Primitive INTERACTIVE_EVAL = new Primitive("interactive-eval", PACKAGE_SYS, true) { Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sun Jul 25 15:09:13 2010 @@ -657,6 +657,23 @@ if (entry instanceof Cons) return ((Cons)entry).cdr; } + if(docType == Symbol.FUNCTION && this instanceof Symbol) { + Object fn = ((Symbol)this).getSymbolFunction(); + if(fn instanceof Function) { + DocString ds = fn.getClass().getAnnotation(DocString.class); + if(ds != null) { + String arglist = ds.args(); + String docstring = ds.doc(); + if(arglist.length() != 0) + ((Function)fn).setLambdaList(new SimpleString(arglist)); + if(docstring.length() != 0) { + SimpleString doc = new SimpleString(docstring); + ((Symbol)this).setDocumentation(Symbol.FUNCTION, doc); + return doc; + } + } + } + } return NIL; } Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Sun Jul 25 15:09:13 2010 @@ -860,7 +860,7 @@ return unreadableString(sb.toString()); } - // ### make-thread + @DocString(name="make-thread", args="function &optional &key name") private static final Primitive MAKE_THREAD = new Primitive("make-thread", PACKAGE_THREADS, true, "function &optional &key name") { @@ -886,10 +886,10 @@ } }; - // ### threadp + @DocString(name="threadp", args="object", + doc="Boolean predicate testing if OBJECT is a thread.") private static final Primitive THREADP = - new Primitive("threadp", PACKAGE_THREADS, true, "object", - "Boolean predicate as whether OBJECT is a thread.") + new Primitive("threadp", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject arg) @@ -898,7 +898,8 @@ } }; - // ### thread-alive-p + @DocString(name="thread-alive-p", args="thread", + doc="Returns T if THREAD is alive.") private static final Primitive THREAD_ALIVE_P = new Primitive("thread-alive-p", PACKAGE_THREADS, true, "thread", "Boolean predicate whether THREAD is alive.") @@ -917,10 +918,10 @@ } }; - // ### thread-name + @DocString(name="thread-name", args="thread", + doc="Return the name of THREAD, if it has one.") private static final Primitive THREAD_NAME = - new Primitive("thread-name", PACKAGE_THREADS, true, "thread", - "Return the name of THREAD if it has one.") + new Primitive("thread-name", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject arg) @@ -972,9 +973,10 @@ return (d < Long.MAX_VALUE ? (long) d : Long.MAX_VALUE); } - // ### sleep - private static final Primitive SLEEP = new Primitive("sleep", PACKAGE_CL, true, "seconds", - "Causes the invoking thread to sleep for SECONDS seconds.\nSECONDS may be a value between 0 1and 1.") + @DocString(name="sleep", args="seconds", + doc="Causes the invoking thread to sleep for SECONDS seconds.\n"+ + "SECONDS may be a value between 0 1and 1.") + private static final Primitive SLEEP = new Primitive("sleep", PACKAGE_CL, true) { @Override public LispObject execute(LispObject arg) @@ -990,10 +992,10 @@ } }; - // ### mapcar-threads + @DocString(name="mapcar-threads", args= "function", + doc="Applies FUNCTION to all existing threads.") private static final Primitive MAPCAR_THREADS = - new Primitive("mapcar-threads", PACKAGE_THREADS, true, "function", - "Applies FUNCTION to all existing threads.") + new Primitive("mapcar-threads", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject arg) @@ -1011,10 +1013,9 @@ } }; - // ### destroy-thread + @DocString(name="destroy-thread", args="thread", doc="Mark THREAD as destroyed") private static final Primitive DESTROY_THREAD = - new Primitive("destroy-thread", PACKAGE_THREADS, true, "thread", - "Mark THREAD as destroyed.") + new Primitive("destroy-thread", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject arg) @@ -1031,11 +1032,12 @@ } }; - // ### interrupt-thread thread function &rest args => T - // Interrupts thread and forces it to apply function to args. When the - // function returns, the thread's original computation continues. If - // multiple interrupts are queued for a thread, they are all run, but the - // order is not guaranteed. + // => T + @DocString(name="interrupt-thread", args="thread function &rest args", + doc="Interrupts thread and forces it to apply function to args. When the\n"+ + "function returns, the thread's original computation continues. If\n"+ + "multiple interrupts are queued for a thread, they are all run, but the\n"+ + "order is not guaranteed.") private static final Primitive INTERRUPT_THREAD = new Primitive("interrupt-thread", PACKAGE_THREADS, true, "thread function &rest args", @@ -1062,10 +1064,10 @@ } }; - // ### current-thread + @DocString(name="current-thread", + doc="Returns a reference to invoking thread.") private static final Primitive CURRENT_THREAD = - new Primitive("current-thread", PACKAGE_THREADS, true, "", - "Returns a reference to invoking thread.") + new Primitive("current-thread", PACKAGE_THREADS, true) { @Override public LispObject execute() @@ -1074,10 +1076,10 @@ } }; - // ### backtrace + @DocString(name="backtrace", + doc="Returns a backtrace of the invoking thread.") private static final Primitive BACKTRACE = - new Primitive("backtrace", PACKAGE_SYS, true, "", - "Returns a backtrace of the invoking thread.") + new Primitive("backtrace", PACKAGE_SYS, true) { @Override public LispObject execute(LispObject[] args) @@ -1089,9 +1091,9 @@ return currentThread().backtrace(limit); } }; - // ### frame-to-string + @DocString(name="frame-to-string", args="frame") private static final Primitive FRAME_TO_STRING = - new Primitive("frame-to-string", PACKAGE_SYS, true, "frame") + new Primitive("frame-to-string", PACKAGE_SYS, true) { @Override public LispObject execute(LispObject[] args) @@ -1104,9 +1106,9 @@ } }; - // ### frame-to-list + @DocString(name="frame-to-list", args="frame") private static final Primitive FRAME_TO_LIST = - new Primitive("frame-to-list", PACKAGE_SYS, true, "frame") + new Primitive("frame-to-list", PACKAGE_SYS, true) { @Override public LispObject execute(LispObject[] args) @@ -1120,7 +1122,7 @@ }; - // ### use-fast-calls + @DocString(name="use-fast-calls") private static final Primitive USE_FAST_CALLS = new Primitive("use-fast-calls", PACKAGE_SYS, true) { @@ -1132,7 +1134,7 @@ } }; - // ### synchronized-on + @DocString(name="synchronized-on", args="form &body body") private static final SpecialOperator SYNCHRONIZED_ON = new SpecialOperator("synchronized-on", PACKAGE_THREADS, true, "form &body body") @@ -1151,10 +1153,9 @@ } }; - // ### object-wait + @DocString(name="object-wait", args="object &optional timeout") private static final Primitive OBJECT_WAIT = - new Primitive("object-wait", PACKAGE_THREADS, true, - "object &optional timeout") + new Primitive("object-wait", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject object) @@ -1189,7 +1190,7 @@ } }; - // ### object-notify + @DocString(name="object-notify", args="object") private static final Primitive OBJECT_NOTIFY = new Primitive("object-notify", PACKAGE_THREADS, true, "object") @@ -1208,10 +1209,9 @@ } }; - // ### object-notify-all + @DocString(name="object-notify-all", args="object") private static final Primitive OBJECT_NOTIFY_ALL = - new Primitive("object-notify-all", PACKAGE_THREADS, true, - "object") + new Primitive("object-notify-all", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject object) Modified: trunk/abcl/src/org/armedbear/lisp/Operator.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Operator.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Operator.java Sun Jul 25 15:09:13 2010 @@ -53,6 +53,11 @@ public final LispObject getLambdaList() { + if(lambdaList == null) { + DocString ds = getClass().getAnnotation(DocString.class); + if(ds != null) + lambdaList = new SimpleString(ds.args()); + } return lambdaList; } Modified: trunk/abcl/src/org/armedbear/lisp/Primitive.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitive.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitive.java Sun Jul 25 15:09:13 2010 @@ -45,6 +45,11 @@ super(name); } + public Primitive(Symbol symbol) + { + super(symbol); + } + public Primitive(Symbol symbol, String arglist) { super(symbol, arglist); Modified: trunk/abcl/src/org/armedbear/lisp/logorc2.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/logorc2.java (original) +++ trunk/abcl/src/org/armedbear/lisp/logorc2.java Sun Jul 25 15:09:13 2010 @@ -37,9 +37,9 @@ import java.math.BigInteger; -// ### logorc2 // logorc2 integer-1 integer-2 => result-integer // or integer-1 with complement of integer-2 + at DocString(name="logorc2", args="integer-1 integer-2") public final class logorc2 extends Primitive { private logorc2() Modified: trunk/abcl/src/org/armedbear/lisp/package_error_package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/package_error_package.java (original) +++ trunk/abcl/src/org/armedbear/lisp/package_error_package.java Sun Jul 25 15:09:13 2010 @@ -35,7 +35,7 @@ import static org.armedbear.lisp.Lisp.*; -// ### package-error-package + at DocString(name="package-error-package") public final class package_error_package extends Primitive { private package_error_package() From astalla at common-lisp.net Sun Jul 25 19:47:38 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 25 Jul 2010 15:47:38 -0400 Subject: [armedbear-cvs] r12827 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Jul 25 15:47:37 2010 New Revision: 12827 Log: Fix ticket #103: DOCUMENTATION is not autoloaded. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp 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 Sun Jul 25 15:47:37 2010 @@ -418,6 +418,8 @@ (in-package "COMMON-LISP") +(sys::autoload '(documentation) "clos") + (sys::autoload '(write print prin1 princ pprint write-to-string prin1-to-string princ-to-string write-char write-string write-line terpri finish-output From astalla at common-lisp.net Mon Jul 26 22:26:10 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 26 Jul 2010 18:26:10 -0400 Subject: [armedbear-cvs] r12828 - trunk/abcl Message-ID: Author: astalla Date: Mon Jul 26 18:26:08 2010 New Revision: 12828 Log: Updated changelog for new release. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Mon Jul 26 18:26:08 2010 @@ -1,7 +1,46 @@ +Version 0.21 +============ +svn://common-lisp.net/project/armedbear/svn/tags/0.21.0/abcl +(???, 2010) + + +Features +-------- + +* [svn r12818] Update to ASDF 2.004 + +* [svn r12738-805] Support for custom CLOS slot definitions and custom class options. + +* [svn r12756] slot-* functions work on structures too. + +* [svn r12774] Improved Java integration: jmake-proxy can implement more than one interface. + +* [svn r12773] Improved Java integration: functions to dynamically manipulate the classpath. + +* [svn r12755] Improved Java integration: CL:STRING can convert Java strings to Lisp strings. + +Fixes +----- + +* [svn 12809-10-20] Various printing fixes. + +* [svn 12804] Fixed elimination of unused local functions shadowed by macrolet. + +* [svn r12798-803] Fixed pathname serialization across OSes. On Windows pathnames are always printed with forward slashes, but can still be read with backslashes. + +* [svn r12740] Make JSR-223 classes compilable with Java 1.5 + +Other +----- + +* [svn r12754] Changed class file generation and FASL loading to minimize reflection. + +* [svn r12734] A minimal Swing GUI Console with a REPL is now included with ABCL. + Version 0.20 ============ -yet-to-be-tagged -(???) +svn://common-lisp.net/project/armedbear/svn/tags/0.20.0/abcl +(24 May, 2010) Features From astalla at common-lisp.net Tue Jul 27 21:16:37 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 27 Jul 2010 17:16:37 -0400 Subject: [armedbear-cvs] r12829 - public_html Message-ID: Author: astalla Date: Tue Jul 27 17:16:34 2010 New Revision: 12829 Log: Release notes for version 0.21. Added: public_html/release-notes-0.21.shtml - copied, changed from r12828, /public_html/release-notes-0.20.shtml Copied: public_html/release-notes-0.21.shtml (from r12828, /public_html/release-notes-0.20.shtml) ============================================================================== --- /public_html/release-notes-0.20.shtml (original) +++ public_html/release-notes-0.21.shtml Tue Jul 27 17:16:34 2010 @@ -3,42 +3,41 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> - ABCL - Release notes v0.20 + ABCL - Release notes v0.21
-

ABCL - Release notes for version 0.20

+

ABCL - Release notes for version 0.21

-

Most notable changes in ABCL 0.20

+

Most notable changes in ABCL 0.21

-

Release notes for older releases.

+

Release notes for older releases.

-
Support for metaclasses
-
ABCL now supports user-defined CLOS metaclasses. The MOP has been improved and extended to accomodate for this new feature. This is the first funded feature added to ABCL: funds were provided to implement it and the relevant tests. As a consequence of the addition of this important feature, the JAVA-CLASS built-in metaclass has been reimplemented in Lisp and has been improved in the process.
-
Support for URLs as pathnames
-
Pathnames can now be used to represent URLs: PATHNAME-JAR and PATHNAME-URL subtypes now handle Jar and URL references working for OPEN, LOAD, PROBE-FILE, FILE-WRITE-DATE, DIRECTORY, et. al. See Ticket #95 for more details.
-
ASDF2
-
The version of ASDF included in ABCL has been updated to ASDF2 (specifically to ASDF 1.719). This version of ASDF is integrated with URL support in pathnames (see the previous point) and is thus capable of loading Lisp systems directly from Jar archives.
-
Multithreading enhancements
-
Threads started through MAKE-THREAD now have a thread-termination restart available, and the THREADS:THREAD-JOIN primitive has been implemented.
-
Bug fixes and speed improvements
-
Several bugs have been fixed and many small speed improvements have been introduced.
+
OS-independent pathname representation in FASLs
+
A long-withstanding bug which clearly manifested in release 0.20 with the integration of ASDF 2: pathnames were externalized in FASLs using their OS-dependent printed representation. Thus FASLs containing literal pathnames compiled on Windows didn't work correctly on Linux. This bug has been fixed in this release by always externalizing pathnames using '/' as a separator, so they can be correctly read back on all major OSes.
+
ASDF2 updated
+
ASDF has been updated to version 2.004.
+
CLOS/MOP enhancements
+
It is now possible to define custom slot definition metaobjects and to add custom defclass options to user-defined metaclasses. It is also now possible to use slot-value, (setf slot-value), and slot-boundp on structure objects.
+
Java interop enhancements
+
Java integration has been enhanced: the classpath can now be manipulated and inspected at runtime; a proxy implementing multiple interfaces in Lisp can be produced; and CL:STRING has been extended to call toString() on Java objects.
+
Other minor bug fixes
+
Including a few fixes on how certain objects are printed, a MACROLET bug, and support for JSR-223 with Java 1.5. Consult the CHANGES file distributed with ABCL for more details.
-

Back to Common-lisp.net.

From astalla at common-lisp.net Wed Jul 28 18:58:40 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 28 Jul 2010 14:58:40 -0400 Subject: [armedbear-cvs] r12830 - public_html Message-ID: Author: astalla Date: Wed Jul 28 14:58:37 2010 New Revision: 12830 Log: Updated home page with release 0.21 Modified: public_html/index.shtml public_html/left-menu Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Wed Jul 28 14:58:37 2010 @@ -61,24 +61,24 @@ Binary - abcl-bin-0.20.0.tar.gz - (pgp) + abcl-bin-0.21.0.tar.gz + (pgp) - abcl-bin-0.20.0.zip - (pgp) + abcl-bin-0.21.0.zip + (pgp) Source - abcl-src-0.20.0.tar.gz - (pgp) + abcl-src-0.21.0.tar.gz + (pgp) - abcl-src-0.20.0.zip - (pgp) + abcl-src-0.21.0.zip + (pgp) Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Wed Jul 28 14:58:37 2010 @@ -1,7 +1,7 @@
Project page
Testimonials
-Release notes
+Release notes
Paid support
From astalla at common-lisp.net Wed Jul 28 22:13:16 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 28 Jul 2010 18:13:16 -0400 Subject: [armedbear-cvs] r12831 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Jul 28 18:13:15 2010 New Revision: 12831 Log: First stab at Java collections integration with the sequences protocol. Added: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/java.lisp 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 Wed Jul 28 18:13:15 2010 @@ -97,18 +97,31 @@ return T; if (type == BuiltInClass.JAVA_OBJECT) return T; - if(type.typep(LispClass.findClass(JAVA_CLASS, false)) != NIL) { + LispObject cls = NIL; + if(type instanceof Symbol) { + cls = LispClass.findClass(type, false); + } + if(cls == NIL) { + cls = type; + } + if(cls.typep(LispClass.findClass(JAVA_CLASS, false)) != NIL) { if(obj != null) { - Class c = (Class) JAVA_CLASS_JCLASS.execute(type).javaInstance(); + Class c = (Class) JAVA_CLASS_JCLASS.execute(cls).javaInstance(); return c.isAssignableFrom(obj.getClass()) ? T : NIL; } else { return T; } + } else if(cls == BuiltInClass.SEQUENCE) { + //This information is replicated here from java.lisp; it is a very + //specific case, not worth implementing CPL traversal in typep + if(java.util.List.class.isInstance(obj) || + java.util.Set.class.isInstance(obj)) { + return T; + } } return super.typep(type); } - @Override public LispObject STRING() { Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Jul 28 18:13:15 2010 @@ -186,6 +186,7 @@ "inspect.lisp" ;;"j.lisp" "java.lisp" + "java-collections.lisp" "known-functions.lisp" "known-symbols.lisp" "late-setf.lisp" Added: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Wed Jul 28 18:13:15 2010 @@ -0,0 +1,145 @@ +(require "CLOS") +(require "JAVA") +(require "EXTENSIBLE-SEQUENCES") + +(in-package :java) + +(defmethod print-object ((coll (jclass "java.util.Collection")) stream) + (print-unreadable-object (coll stream :type t :identity t) + (format stream "~A ~A" + (jclass-of coll) + (jcall "toString" coll)))) + +;;Lists (java.util.List) are the Java counterpart to Lisp SEQUENCEs. +(defun jlist-add (list item) + (jcall (jmethod "java.util.List" "add" "java.lang.Object") + list item)) + +(defun jlist-set (list index item) + (jcall (jmethod "java.util.List" "set" "int" "java.lang.Object") + list index item)) + +(defun jlist-get (list index) + (jcall (jmethod "java.util.List" "get" "int") + list index)) + +(defmethod sequence:length ((s (jclass "java.util.List"))) + (jcall (jmethod "java.util.Collection" "size") s)) + +(defmethod sequence:elt ((s (jclass "java.util.List")) index) + (jlist-get s index)) + +(defmethod (setf sequence:elt) (value (list (jclass "java.util.List")) index) + (jlist-set list index value) + value) + +(defmethod sequence:make-sequence-like + ((s (jclass "java.util.List")) length + &rest args &key initial-element initial-contents) + (declare (ignorable initial-element initial-contents)) + (apply #'make-jsequence-like s #'jlist-add args)) + +(defun make-jsequence-like + (s add-fn &key (initial-element nil iep) (initial-contents nil icp)) + (let ((seq (jnew (jclass-of s)))) + (cond + ((and icp iep) + (error "Can't specify both :initial-element and :initial-contents")) + (icp + (dotimes (i length) + (funcall add-fn seq (elt initial-contents i)))) ;;TODO inefficient, use iterator + (t + (dotimes (i length) + (funcall add-fn seq initial-element)))) + seq)) + +;;TODO: destruct doesn't signal an error for too-many-args for its options +;;e.g. this didn't complain: +;;(defstruct (jlist-iterator (:type list :conc-name #:jlist-it-)) +(defstruct (jlist-iterator (:type list) (:conc-name #:jlist-it-)) + (native-iterator (error "Native iterator required") :read-only t) + element + index) + +(defmethod sequence:make-simple-sequence-iterator + ((s (jclass "java.util.List")) &key from-end (start 0) end) + (let* ((end (or end (length s))) + (index (if from-end (1- end) start)) + (it (jcall "listIterator" s index)) + (iter (make-jlist-iterator :native-iterator it + :index (if from-end (1+ index) + (1- index)))) + (limit (if from-end start (1- end)))) + ;;CL iterator semantics are that first element is present from the start + (unless (sequence:iterator-endp s iter limit from-end) + (sequence:iterator-step s iter from-end)) + (values iter limit from-end))) + +;;Collection, and not List, because we want to reuse this for Set when applicable +(defmethod sequence:iterator-step + ((s (jclass "java.util.Collection")) it from-end) + (if from-end + (progn + (setf (jlist-it-element it) + (jcall "previous" (jlist-it-native-iterator it))) + (decf (jlist-it-index it))) + (progn + (setf (jlist-it-element it) + (jcall "next" (jlist-it-native-iterator it))) + (incf (jlist-it-index it)))) + it) + +(defmethod sequence:iterator-endp + ((s (jclass "java.util.Collection")) it limit from-end) + (if from-end + (<= (jlist-it-index it) limit) + (>= (jlist-it-index it) limit))) + +(defmethod sequence:iterator-element + ((s (jclass "java.util.Collection")) iterator) + (declare (ignore s)) + (jlist-it-element iterator)) + +(defmethod (setf sequence:iterator-element) + (new-value (s (jclass "java.util.Collection")) it) + (jcall "set" (jlist-it-native-iterator it) new-value)) + +(defmethod sequence:iterator-index + ((s (jclass "java.util.Collection")) iterator) + (declare (ignore s)) + (jlist-it-index iterator)) + +(defmethod sequence:iterator-copy ((s (jclass "java.util.Collection")) iterator) + (declare (ignore s iterator)) + (error "iterator-copy not supported for Java iterators.")) + +;;However, it makes sense to have some sequence functions available for Sets +;;(java.util.Set) too, even if they're not sequences. +(defun jset-add (set item) + (jcall (jmethod "java.util.Set" "add" "java.lang.Object") + set item)) + +(defmethod sequence:length ((s (jclass "java.util.Set"))) + (jcall (jmethod "java.util.Collection" "size") s)) + +(defmethod sequence:make-sequence-like + ((s (jclass "java.util.Set")) length + &rest args &key initial-element initial-contents) + (declare (ignorable initial-element initial-contents)) + (apply #'make-jsequence-like s #'jset-add args)) + +(defmethod sequence:make-simple-sequence-iterator + ((s (jclass "java.util.Set")) &key from-end (start 0) end) + (when (or from-end (not (= start 0))) + (error "Java Sets can only be iterated from the start.")) + (let* ((end (or end (length s))) + (it (jcall "iterator" s)) + (iter (make-jlist-iterator :native-iterator it + :index -1)) + (limit (1- end))) + ;;CL iterator semantics are that first element is present from the start + (unless (sequence:iterator-endp s iter limit nil) + (sequence:iterator-step s iter nil)) + (values iter limit nil))) + +(provide :java-collections) \ No newline at end of file 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 Wed Jul 28 18:13:15 2010 @@ -149,6 +149,11 @@ method implementation))))) lisp-this)) +(defun jequal (obj1 obj2) + "Compares obj1 with obj2 using java.lang.Object.equals()" + (jcall (jmethod "java.lang.Object" "equals" "java.lang.Object") + obj1 obj2)) + (defun jobject-class (obj) "Returns the Java class that OBJ belongs to" (jcall (jmethod "java.lang.Object" "getClass") obj)) @@ -363,6 +368,15 @@ :direct-superclasses (list (find-class 'java-object)) :java-class +java-lang-object+))) +(defun jclass-additional-superclasses (jclass) + "Extension point to put additional CLOS classes on the CPL of a CLOS Java class." + (let ((supers nil)) + (when (jclass-interface-p jclass) + (push (find-class 'java-object) supers)) + (when (jequal jclass (jclass "java.util.List")) + (push (find-class 'sequence) supers)) + supers)) + (defun ensure-java-class (jclass) (let ((class (%find-java-class jclass))) (if class @@ -378,9 +392,7 @@ (concatenate 'list (list (jclass-superclass jclass)) (jclass-interfaces jclass)))))) - (if (jclass-interface-p jclass) - (append supers (list (find-class 'java-object))) - supers)) + (append supers (jclass-additional-superclasses jclass))) :java-class jclass))))) (defmethod mop::compute-class-precedence-list ((class java-class)) From ehuelsmann at common-lisp.net Thu Jul 29 18:27:12 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 29 Jul 2010 14:27:12 -0400 Subject: [armedbear-cvs] r12832 - in branches/generic-class-file/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: ehuelsmann Date: Thu Jul 29 14:27:10 2010 New Revision: 12832 Log: Lots of fixes from writing tests. Most notable the correction of my perception that the exceptions table was stored as an attribute of the "Code" attribute. It's not: it's part of said attribute. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jul 29 14:27:10 2010 @@ -1304,11 +1304,10 @@ ;; Current path ends. (return-from walk-code)))))) -(declaim (ftype (function () t) analyze-stack)) -(defun analyze-stack () +(declaim (ftype (function (t) t) analyze-stack)) +(defun analyze-stack (code) (declare (optimize speed)) - (let* ((code *code*) - (code-length (length code))) + (let* ((code-length (length code))) (declare (type vector code)) (dotimes (i code-length) (declare (type (unsigned-byte 16) i)) @@ -1572,7 +1571,9 @@ t) (defun code-bytes (code) - (let ((length 0)) + (let ((length 0) + labels ;; alist + ) (declare (type (unsigned-byte 16) length)) ;; Pass 1: calculate label offsets and overall length. (dotimes (i (length code)) @@ -1581,7 +1582,9 @@ (opcode (instruction-opcode instruction))) (if (= opcode 202) ; LABEL (let ((label (car (instruction-args instruction)))) - (set label length)) + (set label length) + (setf labels + (acons label length labels))) (incf length (opcode-size opcode))))) ;; Pass 2: replace labels with calculated offsets. (let ((index 0)) @@ -1608,7 +1611,7 @@ (dolist (byte (instruction-args instruction)) (setf (svref bytes index) byte) (incf index))))) - bytes))) + (values bytes labels)))) (declaim (inline write-u1)) (defun write-u1 (n stream) @@ -1878,7 +1881,7 @@ (emit 'return) (finalize-code) (setf *code* (resolve-instructions *code*)) - (setf (method-max-stack constructor) (analyze-stack)) + (setf (method-max-stack constructor) (analyze-stack *code*)) (setf (method-code constructor) (code-bytes *code*)) (setf (method-handlers constructor) (nreverse *handlers*)) constructor)) @@ -8205,7 +8208,7 @@ (optimize-code) (setf *code* (resolve-instructions *code*)) - (setf (method-max-stack execute-method) (analyze-stack)) + (setf (method-max-stack execute-method) (analyze-stack *code*)) (setf (method-code execute-method) (code-bytes *code*)) ;; Remove handler if its protected range is empty. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Thu Jul 29 14:27:10 2010 @@ -180,14 +180,14 @@ "Returns a string describing the `return-type' and `argument-types' in JVM-internal representation." (format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types) - (internal-field-type return-type))) + (internal-field-ref return-type))) (defstruct pool - ;; `count' contains a reference to the last-used slot (0 being empty) + ;; `index' contains the index of the last allocated slot (0 == empty) ;; "A constant pool entry is considered valid if it has ;; an index greater than 0 (zero) and less than pool-count" - (count 0) + (index 0) entries-list ;; the entries hash stores raw values, except in case of string and ;; utf8, because both are string values @@ -284,7 +284,7 @@ (defstruct (constant-utf8 (:constructor make-constant-utf8 (index value)) (:include constant - (tag 11))) + (tag 1))) value) @@ -294,11 +294,10 @@ `class' must be an instance of `class-name'." (let ((entry (gethash class (pool-entries pool)))) (unless entry - (setf entry - (make-constant-class (incf (pool-count pool)) - (pool-add-utf8 pool - (class-name-internal class))) - (gethash class (pool-entries pool)) entry) + (let ((utf8 (pool-add-utf8 pool (class-name-internal class)))) + (setf entry + (make-constant-class (incf (pool-index pool)) utf8) + (gethash class (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -311,10 +310,10 @@ `type' is a field-type (see `internal-field-type')" (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (setf entry (make-constant-field-ref (incf (pool-count pool)) - (pool-add-class pool class) - (pool-add-name/type pool name type)) - (gethash (acons name type class) (pool-entries pool)) entry) + (let ((c (pool-add-class pool class)) + (n/t (pool-add-name/type pool name type))) + (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t) + (gethash (acons name type class) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -326,10 +325,10 @@ and return type. `class' is an instance of `class-name'." (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (setf entry (make-constant-method-ref (incf (pool-count pool)) - (pool-add-class pool class) - (pool-add-name/type pool name type)) - (gethash (acons name type class) (pool-entries pool)) entry) + (let ((c (pool-add-class pool class)) + (n/t (pool-add-name/type pool name type))) + (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t) + (gethash (acons name type class) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -340,12 +339,11 @@ See `pool-add-method-ref' for remarks." (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (setf entry - (make-constant-interface-method-ref (incf (pool-count pool)) - (pool-add-class pool class) - (pool-add-name/type pool - name type)) - (gethash (acons name type class) (pool-entries pool)) entry) + (let ((c (pool-add-class pool class)) + (n/t (pool-add-name/type pool name type))) + (setf entry + (make-constant-interface-method-ref (incf (pool-index pool)) c n/t) + (gethash (acons name type class) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -354,9 +352,9 @@ (let ((entry (gethash (cons 8 string) ;; 8 == string-tag (pool-entries pool)))) (unless entry - (setf entry (make-constant-string (incf (pool-count pool)) - (pool-add-utf8 pool string)) - (gethash (cons 8 string) (pool-entries pool)) entry) + (let ((utf8 (pool-add-utf8 pool string))) + (setf entry (make-constant-string (incf (pool-index pool)) utf8) + (gethash (cons 8 string) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -364,7 +362,7 @@ "Returns the index of the constant-pool item denoting the int." (let ((entry (gethash (cons 3 int) (pool-entries pool)))) (unless entry - (setf entry (make-constant-int (incf (pool-count pool)) int) + (setf entry (make-constant-int (incf (pool-index pool)) int) (gethash (cons 3 int) (pool-entries pool)) entry) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -373,7 +371,7 @@ "Returns the index of the constant-pool item denoting the float." (let ((entry (gethash (cons 4 float) (pool-entries pool)))) (unless entry - (setf entry (make-constant-float (incf (pool-count pool)) float) + (setf entry (make-constant-float (incf (pool-index pool)) float) (gethash (cons 4 float) (pool-entries pool)) entry) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -382,20 +380,20 @@ "Returns the index of the constant-pool item denoting the long." (let ((entry (gethash (cons 5 long) (pool-entries pool)))) (unless entry - (setf entry (make-constant-long (incf (pool-count pool)) long) + (setf entry (make-constant-long (incf (pool-index pool)) long) (gethash (cons 5 long) (pool-entries pool)) entry) (push entry (pool-entries-list pool)) - (incf (pool-count pool))) ;; double index increase; long takes 2 slots + (incf (pool-index pool))) ;; double index increase; long takes 2 slots (constant-index entry))) (defun pool-add-double (pool double) "Returns the index of the constant-pool item denoting the double." (let ((entry (gethash (cons 6 double) (pool-entries pool)))) (unless entry - (setf entry (make-constant-double (incf (pool-count pool)) double) + (setf entry (make-constant-double (incf (pool-index pool)) double) (gethash (cons 6 double) (pool-entries pool)) entry) (push entry (pool-entries-list pool)) - (incf (pool-count pool))) ;; double index increase; 'double' takes 2 slots + (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots (constant-index entry))) (defun pool-add-name/type (pool name type) @@ -406,10 +404,10 @@ (apply #'descriptor type) (internal-field-ref type)))) (unless entry - (setf entry (make-constant-name/type (incf (pool-count pool)) - (pool-add-utf8 pool name) - (pool-add-utf8 pool internal-type)) - (gethash (cons name type) (pool-entries pool)) entry) + (let ((n (pool-add-utf8 pool name)) + (i-t (pool-add-utf8 pool internal-type))) + (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t) + (gethash (cons name type) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -419,7 +417,7 @@ (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8 (pool-entries pool)))) (unless entry - (setf entry (make-constant-utf8 (incf (pool-count pool)) utf8-as-string) + (setf entry (make-constant-utf8 (incf (pool-index pool)) utf8-as-string) (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -478,13 +476,17 @@ "Transforms the representation of the class-file from one which allows easy modification to one which works best for serialization. -The class can't be modified after serialization." +The class can't be modified after finalization." + ;; constant pool contains constants finalized on addition; ;; no need for additional finalization (setf (class-file-access-flags class) (map-flags (class-file-access-flags class))) - (setf (class-file-class class) + (setf (class-file-superclass class) + (pool-add-class (class-file-constants class) + (class-file-superclass class)) + (class-file-class class) (pool-add-class (class-file-constants class) (class-file-class class))) ;; (finalize-interfaces) @@ -508,6 +510,7 @@ ;; flags (write-u2 (class-file-access-flags class) stream) ;; class name + (write-u2 (class-file-class class) stream) ;; superclass (write-u2 (class-file-superclass class) stream) @@ -528,32 +531,65 @@ ;; attributes (write-attributes (class-file-attributes class) stream)) + +(defvar *jvm-class-debug-pool* nil + "When bound to a non-NIL value, enables output to *standard-output* +to allow debugging output of the constant section of the class file.") + (defun write-constants (constants stream) - (write-u2 (pool-count constants) stream) - (dolist (entry (reverse (pool-entries-list constants))) - (let ((tag (constant-tag entry))) - (write-u1 tag stream) + "Writes the constant section given in `constants' to the class file `stream'." + (let ((pool-index 0)) + (write-u2 (1+ (pool-index constants)) stream) + (when *jvm-class-debug-pool* + (sys::%format t "pool count ~A~%" (pool-index constants))) + (dolist (entry (reverse (pool-entries-list constants))) + (incf pool-index) + (let ((tag (constant-tag entry))) + (when *jvm-class-debug-pool* + (print-constant entry t)) + (write-u1 tag stream) + (case tag + (1 ; UTF8 + (write-utf8 (constant-utf8-value entry) stream)) + ((3 4) ; float int + (write-u4 (constant-float/int-value entry) stream)) + ((5 6) ; long double + (write-u4 (logand (ash (constant-double/long-value entry) -32) + #xFFFFffff) stream) + (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) + stream)) + ((9 10 11) ; fieldref methodref InterfaceMethodref + (write-u2 (constant-member-ref-class-index entry) stream) + (write-u2 (constant-member-ref-name/type-index entry) stream)) + (12 ; nameAndType + (write-u2 (constant-name/type-name-index entry) stream) + (write-u2 (constant-name/type-descriptor-index entry) stream)) + (7 ; class + (write-u2 (constant-class-name-index entry) stream)) + (8 ; string + (write-u2 (constant-string-value-index entry) stream)) + (t + (error "write-constant-pool-entry unhandled tag ~D~%" tag))))))) + + +(defun print-constant (entry stream) + "Debugging helper to print the content of a constant-pool entry." + (let ((tag (constant-tag entry)) + (index (constant-index entry))) + (sys::%format stream "pool element ~a, tag ~a, " index tag) (case tag - (1 ; UTF8 - (write-utf8 (constant-utf8-value entry) stream)) - ((3 4) ; int - (write-u4 (constant-float/int-value entry) stream)) - ((5 6) ; long double - (write-u4 (logand (ash (constant-double/long-value entry) -32) - #xFFFFffff) stream) - (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) stream)) - ((9 10 11) ; fieldref methodref InterfaceMethodref - (write-u2 (constant-member-ref-class-index entry) stream) - (write-u2 (constant-member-ref-name/type-index entry) stream)) - (12 ; nameAndType - (write-u2 (constant-name/type-name-index entry) stream) - (write-u2 (constant-name/type-descriptor-index entry) stream)) - (7 ; class - (write-u2 (constant-class-name-index entry) stream)) - (8 ; string - (write-u2 (constant-string-value-index entry) stream)) - (t - (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))) + (1 (sys::%format t "utf8: ~a~%" (constant-utf8-value entry))) + ((3 4) (sys::%format t "f/i: ~a~%" (constant-float/int-value entry))) + ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry))) + ((9 10 11) (sys::%format t "ref: ~a,~a~%" + (constant-member-ref-class-index entry) + (constant-member-ref-name/type-index entry))) + (12 (sys::%format t "n/t: ~a,~a~%" + (constant-name/type-name-index entry) + (constant-name/type-descriptor-index entry))) + (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry))) + (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry)))))) + #| @@ -575,7 +611,9 @@ (:transient #x0080) (:native #x0100) (:abstract #x0400) - (:strict #x0800))) + (:strict #x0800)) + "List of keyword symbols used for human readable representation of (access) +flags and their binary values.") (defun map-flags (flags) "Calculates the bitmap of the flags from a list of symbols." @@ -587,12 +625,14 @@ :initial-value 0)) (defstruct (field (:constructor %make-field)) + "" access-flags name descriptor attributes) (defun make-field (name type &key (flags '(:public))) + (%make-field :access-flags flags :name name :descriptor type)) @@ -643,20 +683,33 @@ (t name))) (defun !make-method (name return args &key (flags '(:public))) - (%make-method :descriptor (cons return args) + (%!make-method :descriptor (cons return args) :access-flags flags :name name)) (defun method-add-attribute (method attribute) - (push attribute (method-attributes method))) + "Add `attribute' to the list of attributes of `method', +returning `attribute'." + (push attribute (method-attributes method)) + attribute) (defun method-add-code (method) - "Creates an (empty) 'Code' attribute for the method." + "Creates an (empty) 'Code' attribute for the method, +returning the created attribute." (method-add-attribute + method (make-code-attribute (+ (length (cdr (method-descriptor method))) (if (member :static (method-access-flags method)) 0 1))))) ;; 1 == implicit 'this' +(defun method-ensure-code (method) + "Ensures the existence of a 'Code' attribute for the method, +returning the attribute." + (let ((code (method-attribute method "Code"))) + (if (null code) + (method-add-code method) + code))) + (defun method-attribute (method name) (find name (method-attributes method) :test #'string= :key #'attribute-name)) @@ -676,6 +729,7 @@ (defun !write-method (method stream) (write-u2 (method-access-flags method) stream) (write-u2 (method-name method) stream) + (sys::%format t "method-name: ~a~%" (method-name method)) (write-u2 (method-descriptor method) stream) (write-attributes (method-attributes method) stream)) @@ -691,8 +745,8 @@ (dolist (attribute attributes) ;; assure header: make sure 'name' is in the pool (setf (attribute-name attribute) - (pool-add-string (class-file-constants class) - (attribute-name attribute))) + (pool-add-utf8 (class-file-constants class) + (attribute-name attribute))) ;; we're saving "root" attributes: attributes which have no parent (funcall (attribute-finalizer attribute) attribute att class))) @@ -705,7 +759,7 @@ (let ((local-stream (sys::%make-byte-array-output-stream))) (funcall (attribute-writer attribute) attribute local-stream) (let ((array (sys::%get-output-stream-array local-stream))) - (write-u2 (length array) stream) + (write-u4 (length array) stream) (write-sequence array stream))))) @@ -719,34 +773,73 @@ max-stack max-locals code + exception-handlers attributes - ;; labels contains offsets into the code array after it's finalized - (labels (make-hash-table :test #'eq)) ;; fields not in the class file start here - current-local ;; used for handling nested WITH-CODE-TO-METHOD blocks - ) + + ;; labels contains offsets into the code array after it's finalized + labels ;; an alist + + current-local) ;; used for handling nested WITH-CODE-TO-METHOD blocks + (defun code-label-offset (code label) - (gethash label (code-labels code))) + (cdr (assoc label (code-labels code)))) (defun (setf code-label-offset) (offset code label) - (setf (gethash label (code-labels code)) offset)) + (setf (code-labels code) + (acons label offset (code-labels code)))) + + + +(defun !finalize-code (code parent class) + (declare (ignore parent)) + (let ((c (resolve-instructions (coerce (reverse (code-code code)) 'vector)))) + (setf (code-max-stack code) (analyze-stack c)) + (multiple-value-bind + (c labels) + (code-bytes c) + (setf (code-code code) c + (code-labels code) labels))) + + (dolist (exception (code-exception-handlers code)) + (setf (exception-start-pc exception) + (code-label-offset code (exception-start-pc exception)) + (exception-end-pc exception) + (code-label-offset code (exception-end-pc exception)) + (exception-handler-pc exception) + (code-label-offset code (exception-handler-pc exception)) + (exception-catch-type exception) + (if (null (exception-catch-type exception)) + 0 ;; generic 'catch all' class index number + (pool-add-class (class-file-constants class) + (exception-catch-type exception))))) -(defun !finalize-code (code class) - (let ((c (coerce (resolve-instructions (code-code code)) 'vector))) - (setf (code-max-stack code) (analyze-stack c) - (code-code code) (code-bytes c))) (finalize-attributes (code-attributes code) code class)) (defun !write-code (code stream) + (sys::%format t "max-stack: ~a~%" (code-max-stack code)) (write-u2 (code-max-stack code) stream) + (sys::%format t "max-locals: ~a~%" (code-max-locals code)) (write-u2 (code-max-locals code) stream) (let ((code-array (code-code code))) + (sys::%format t "length: ~a~%" (length code-array)) (write-u4 (length code-array) stream) (dotimes (i (length code-array)) (write-u1 (svref code-array i) stream))) + + (write-u2 (length (code-exception-handlers code)) stream) + (dolist (exception (reverse (code-exception-handlers code))) + (sys::%format t "start-pc: ~a~%" (exception-start-pc exception)) + (write-u2 (exception-start-pc exception) stream) + (sys::%format t "end-pc: ~a~%" (exception-end-pc exception)) + (write-u2 (exception-end-pc exception) stream) + (sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception)) + (write-u2 (exception-handler-pc exception) stream) + (write-u2 (exception-catch-type exception) stream)) + (write-attributes (code-attributes code) stream)) (defun make-code-attribute (arg-count) @@ -755,24 +848,44 @@ (%make-code-attribute :max-locals arg-count)) (defun code-add-attribute (code attribute) - (push attribute (code-attributes code))) + "Adds `attribute' to `code', returning `attribute'." + (push attribute (code-attributes code)) + attribute) (defun code-attribute (code name) (find name (code-attributes code) :test #'string= :key #'attribute-name)) +(defun code-add-exception-handler (code start end handler type) + (push (make-exception :start-pc start + :end-pc end + :handler-pc handler + :catch-type type) + (code-exception-handlers code))) + +(defun add-exception-handler (start end handler type) + (code-add-exception-handler *current-code-attribute* start end handler type)) + +(defstruct exception + start-pc ;; label target + end-pc ;; label target + handler-pc ;; label target + catch-type ;; a string for a specific type, or NIL for all + ) + (defvar *current-code-attribute*) (defun save-code-specials (code) (setf (code-code code) *code* (code-max-locals code) *registers-allocated* - (code-exception-handlers code) *handlers* +;; (code-exception-handlers code) *handlers* (code-current-local code) *register*)) (defun restore-code-specials (code) (setf *code* (code-code code) +;; *handlers* (code-exception-handlers code) *registers-allocated* (code-max-locals code) *register* (code-current-local code))) @@ -784,67 +897,19 @@ `((when *current-code-attribute* (save-code-specials *current-code-attribute*)))) (let* ((,m ,method) - (,c (method-attribute ,m "Code")) + (,c (method-ensure-code method)) (*code* (code-code ,c)) (*registers-allocated* (code-max-locals ,c)) (*register* (code-current-local ,c)) (*current-code-attribute* ,c)) , at body (setf (code-code ,c) *code* - (code-exception-handlers ,c) *handlers* +;; (code-exception-handlers ,c) *handlers* (code-max-locals ,c) *registers-allocated*)) ,@(when safe-nesting `((when *current-code-attribute* (restore-code-specials *current-code-attribute*))))))) -(defstruct (exceptions-attribute (:constructor make-exceptions) - (:conc-name exceptions-) - (:include attribute - (name "Exceptions") - (finalizer #'finalize-exceptions) - (writer #'write-exceptions))) - exceptions) - -(defun finalize-exceptions (exceptions code class) - (dolist (exception (exceptions-exceptions exceptions)) - ;; no need to finalize `catch-type': it's already the index required - (setf (exception-start-pc exception) - (code-label-offset code (exception-start-pc exception)) - (exception-end-pc exception) - (code-label-offset code (exception-end-pc exception)) - (exception-handler-pc exception) - (code-label-offset code (exception-handler-pc exception)) - (exception-catch-type exception) - (pool-add-string (class-file-constants class) - (exception-catch-type exception)))) - ;;(finalize-attributes (exceptions-attributes exception) exceptions class) - ) - - -(defun write-exceptions (exceptions stream) - ; number of entries - (write-u2 (length (exceptions-exceptions exceptions)) stream) - (dolist (exception (exceptions-exceptions exceptions)) - (write-u2 (exception-start-pc exception) stream) - (write-u2 (exception-end-pc exception) stream) - (write-u2 (exception-handler-pc exception) stream) - (write-u2 (exception-catch-type exception) stream))) - -(defun code-add-exception (code start end handler type) - (when (null (code-attribute code "Exceptions")) - (code-add-attribute code (make-exceptions))) - (push (make-exception :start-pc start - :end-pc end - :handler-pc handler - :catch-type type) - (exceptions-exceptions (code-attribute code "Exceptions")))) - -(defstruct exception - start-pc ;; label target - end-pc ;; label target - handler-pc ;; label target - catch-type ;; a string for a specific type, or NIL for all - ) (defstruct (source-file-attribute (:conc-name source-) (:include attribute Modified: branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp (original) +++ branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp Thu Jul 29 14:27:10 2010 @@ -65,7 +65,7 @@ T) (deftest fieldtype.2 - (string= (jvm::internal-field-type jvm::+!lisp-object+) + (string= (jvm::internal-field-type jvm::+lisp-object+) "org/armedbear/lisp/LispObject") T) @@ -111,7 +111,7 @@ T) (deftest fieldref.2 - (string= (jvm::internal-field-ref jvm::+!lisp-object+) + (string= (jvm::internal-field-ref jvm::+lisp-object+) "Lorg/armedbear/lisp/LispObject;") T) @@ -124,58 +124,105 @@ T) (deftest descriptor.2 - (string= (jvm::descriptor jvm::+!lisp-object+ jvm::+!lisp-object+) + (string= (jvm::descriptor jvm::+lisp-object+ jvm::+lisp-object+) "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") T) (deftest map-flags.1 - (eql (jvm::map-flags '(:public)) #x0001)) + (eql (jvm::map-flags '(:public)) #x0001) + T) (deftest pool.1 (let* ((pool (jvm::make-pool))) - (jvm::pool-add-class pool jvm::+!lisp-readtable+) - (jvm::pool-add-field-ref pool jvm::+!lisp-readtable+ "ABC" :int) + (jvm::pool-add-class pool jvm::+lisp-readtable+) + (jvm::pool-add-field-ref pool jvm::+lisp-readtable+ "ABC" :int) (jvm::pool-add-field-ref pool - jvm::+!lisp-readtable+ "ABD" - jvm::+!lisp-readtable+) - (jvm::pool-add-method-ref pool jvm::+!lisp-readtable+ "MBC" :int) - (jvm::pool-add-method-ref pool jvm::+!lisp-readtable+ "MBD" - jvm::+!lisp-readtable+) + jvm::+lisp-readtable+ "ABD" + jvm::+lisp-readtable+) + (jvm::pool-add-method-ref pool jvm::+lisp-readtable+ "MBC" :int) + (jvm::pool-add-method-ref pool jvm::+lisp-readtable+ "MBD" + jvm::+lisp-readtable+) (jvm::pool-add-interface-method-ref pool - jvm::+!lisp-readtable+ "MBD" :int) + jvm::+lisp-readtable+ "MBD" :int) (jvm::pool-add-interface-method-ref pool - jvm::+!lisp-readtable+ "MBD" - jvm::+!lisp-readtable+) + jvm::+lisp-readtable+ "MBD" + jvm::+lisp-readtable+) (jvm::pool-add-string pool "string") (jvm::pool-add-int pool 1) (jvm::pool-add-float pool 1.0f0) (jvm::pool-add-long pool 1) (jvm::pool-add-double pool 1.0d0) (jvm::pool-add-name/type pool "name1" :int) - (jvm::pool-add-name/type pool "name2" jvm::+!lisp-object+) + (jvm::pool-add-name/type pool "name2" jvm::+lisp-object+) (jvm::pool-add-utf8 pool "utf8") T) T) (deftest make-class-file.1 (let* ((class (jvm::make-class-name "org/armedbear/lisp/mcf_1")) - (file (jvm::!make-class-file class jvm::+!lisp-object+ '(:public)))) + (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))) (jvm::class-add-field file (jvm::make-field "ABC" :int)) - (jvm::class-add-field file (jvm::make-field "ABD" jvm::+!lisp-object+)) + (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+)) (jvm::class-add-method file (jvm::!make-method "MBC" nil :int)) - (jvm::class-add-method file (jvm::!make-method "MBD" nil jvm::+!lisp-object+)) + (jvm::class-add-method file (jvm::!make-method "MBD" nil jvm::+lisp-object+)) + (jvm::class-add-method file (jvm::!make-method :constructor :void nil)) + (jvm::class-add-method file (jvm::!make-method :class-constructor :void nil)) T) T) (deftest finalize-class-file.1 - (let* ((class (jvm::make-class-name "org/armedbear/lisp/mcf_1")) - (file (jvm::!make-class-file class jvm::+!lisp-object+ '(:public)))) + (let* ((class (jvm::make-class-name "org/armedbear/lisp/fcf_1")) + (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))) (jvm::class-add-field file (jvm::make-field "ABC" :int)) - (jvm::class-add-field file (jvm::make-field "ABD" jvm::+!lisp-object+)) + (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+)) (jvm::class-add-method file (jvm::!make-method "MBC" nil '(:int))) (jvm::class-add-method file (jvm::!make-method "MBD" nil - (list jvm::+!lisp-object+))) + (list jvm::+lisp-object+))) + (jvm::finalize-class-file file) + file + T) + T) + +(deftest generate-method.1 + (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_1")) + (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))) + (method (jvm::!make-method :class-constructor :void nil + :flags '(:static)))) + (jvm::class-add-method file method) + (jvm::with-code-to-method (method) + (jvm::emit 'return)) + (jvm::finalize-class-file file) + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (jvm::!write-class-file file stream) + (sys::load-compiled-function (sys::%get-output-stream-bytes stream))) + T) + T) + +(deftest generate-method.2 + (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_2")) + (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))) + (method (jvm::!make-method "doNothing" :void nil))) + (jvm::class-add-method file method) + (jvm::with-code-to-method (method) + (let ((label1 (gensym)) + (label2 (gensym)) + (label3 (gensym))) + (jvm::label label1) + (jvm::emit 'jvm::iconst_1) + (jvm::label label2) + (jvm::emit 'return) + (jvm::label label3) + (jvm::code-add-exception-handler (jvm::method-attribute method "Code") + label1 label2 label3 nil)) + (jvm::emit 'return)) (jvm::finalize-class-file file) - file) - T) \ No newline at end of file + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (jvm::!write-class-file file stream) + (sys::load-compiled-function (sys::%get-output-stream-bytes stream))) + T) + T) + + +;;(deftest generate-method.2 +;; (let* ((class)))) \ No newline at end of file From astalla at common-lisp.net Thu Jul 29 19:10:45 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 29 Jul 2010 15:10:45 -0400 Subject: [armedbear-cvs] r12833 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu Jul 29 15:10:44 2010 New Revision: 12833 Log: Small fix (a parameter wasn't being passed to make-jsequence-like) Modified: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Modified: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java-collections.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Thu Jul 29 15:10:44 2010 @@ -37,10 +37,10 @@ ((s (jclass "java.util.List")) length &rest args &key initial-element initial-contents) (declare (ignorable initial-element initial-contents)) - (apply #'make-jsequence-like s #'jlist-add args)) + (apply #'make-jsequence-like s length #'jlist-add args)) (defun make-jsequence-like - (s add-fn &key (initial-element nil iep) (initial-contents nil icp)) + (s length add-fn &key (initial-element nil iep) (initial-contents nil icp)) (let ((seq (jnew (jclass-of s)))) (cond ((and icp iep) @@ -126,7 +126,7 @@ ((s (jclass "java.util.Set")) length &rest args &key initial-element initial-contents) (declare (ignorable initial-element initial-contents)) - (apply #'make-jsequence-like s #'jset-add args)) + (apply #'make-jsequence-like s length #'jset-add args)) (defmethod sequence:make-simple-sequence-iterator ((s (jclass "java.util.Set")) &key from-end (start 0) end) From ehuelsmann at common-lisp.net Thu Jul 29 19:38:26 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 29 Jul 2010 15:38:26 -0400 Subject: [armedbear-cvs] r12834 - in branches/generic-class-file/abcl: . src/org/armedbear/lisp test/lisp/ansi Message-ID: Author: ehuelsmann Date: Thu Jul 29 15:38:25 2010 New Revision: 12834 Log: Backport r12805-12833 from trunk. Added: branches/generic-class-file/abcl/src/org/armedbear/lisp/DocString.java - copied unchanged from r12833, /trunk/abcl/src/org/armedbear/lisp/DocString.java branches/generic-class-file/abcl/src/org/armedbear/lisp/java-collections.lisp - copied unchanged from r12833, /trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Modified: branches/generic-class-file/abcl/CHANGES branches/generic-class-file/abcl/build.xml branches/generic-class-file/abcl/src/org/armedbear/lisp/Condition.java branches/generic-class-file/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Java.java branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaObject.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Lisp.java branches/generic-class-file/abcl/src/org/armedbear/lisp/LispObject.java branches/generic-class-file/abcl/src/org/armedbear/lisp/LispThread.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Operator.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitive.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitives.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java branches/generic-class-file/abcl/src/org/armedbear/lisp/Version.java branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/autoloads.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/debug.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/logorc2.java branches/generic-class-file/abcl/src/org/armedbear/lisp/package_error_package.java branches/generic-class-file/abcl/src/org/armedbear/lisp/print.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/threads.lisp branches/generic-class-file/abcl/test/lisp/ansi/package.lisp branches/generic-class-file/abcl/test/lisp/ansi/parse-ansi-errors.lisp Modified: branches/generic-class-file/abcl/CHANGES ============================================================================== --- branches/generic-class-file/abcl/CHANGES (original) +++ branches/generic-class-file/abcl/CHANGES Thu Jul 29 15:38:25 2010 @@ -1,7 +1,46 @@ +Version 0.21 +============ +svn://common-lisp.net/project/armedbear/svn/tags/0.21.0/abcl +(???, 2010) + + +Features +-------- + +* [svn r12818] Update to ASDF 2.004 + +* [svn r12738-805] Support for custom CLOS slot definitions and custom class options. + +* [svn r12756] slot-* functions work on structures too. + +* [svn r12774] Improved Java integration: jmake-proxy can implement more than one interface. + +* [svn r12773] Improved Java integration: functions to dynamically manipulate the classpath. + +* [svn r12755] Improved Java integration: CL:STRING can convert Java strings to Lisp strings. + +Fixes +----- + +* [svn 12809-10-20] Various printing fixes. + +* [svn 12804] Fixed elimination of unused local functions shadowed by macrolet. + +* [svn r12798-803] Fixed pathname serialization across OSes. On Windows pathnames are always printed with forward slashes, but can still be read with backslashes. + +* [svn r12740] Make JSR-223 classes compilable with Java 1.5 + +Other +----- + +* [svn r12754] Changed class file generation and FASL loading to minimize reflection. + +* [svn r12734] A minimal Swing GUI Console with a REPL is now included with ABCL. + Version 0.20 ============ -yet-to-be-tagged -(???) +svn://common-lisp.net/project/armedbear/svn/tags/0.20.0/abcl +(24 May, 2010) Features Modified: branches/generic-class-file/abcl/build.xml ============================================================================== --- branches/generic-class-file/abcl/build.xml (original) +++ branches/generic-class-file/abcl/build.xml Thu Jul 29 15:38:25 2010 @@ -445,8 +445,11 @@ - + + + + Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Condition.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Condition.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Condition.java Thu Jul 29 15:38:25 2010 @@ -104,7 +104,7 @@ public final LispObject getFormatControl() { - return getInstanceSlotValue(Symbol.FORMAT_CONTROL); + return getInstanceSlotValue(Symbol.FORMAT_CONTROL); } public final void setFormatControl(LispObject formatControl) @@ -135,7 +135,8 @@ */ public String getMessage() { - return getFormatControl().toString(); + LispObject formatControl = getFormatControl(); + return formatControl != UNBOUND_VALUE ? formatControl.writeToString() : null; } @Override Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Thu Jul 29 15:38:25 2010 @@ -76,7 +76,7 @@ return unreadableString(sb.toString()); } - // ### make-forward-referenced-class + @DocString(name="make-forward-referenced=class") private static final Primitive MAKE_FORWARD_REFERENCED_CLASS = new Primitive("make-forward-referenced-class", PACKAGE_SYS, true) { Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Function.java Thu Jul 29 15:38:25 2010 @@ -53,7 +53,14 @@ public Function(String name) { + this(name, (String)null); + } + + public Function(String name, String arglist) + { this(); + if(arglist != null) + setLambdaList(new SimpleString(arglist)); if (name != null) { Symbol symbol = Symbol.addFunction(name.toUpperCase(), this); if (cold) @@ -62,14 +69,14 @@ } } + public Function(Symbol symbol) + { + this(symbol, null, null); + } + public Function(Symbol symbol, String arglist) { - this(); - symbol.setSymbolFunction(this); - if (cold) - symbol.setBuiltInFunction(true); - setLambdaName(symbol); - setLambdaList(new SimpleString(arglist)); + this(symbol, arglist, null); } public Function(Symbol symbol, String arglist, String docstring) @@ -79,17 +86,11 @@ if (cold) symbol.setBuiltInFunction(true); setLambdaName(symbol); - setLambdaList(new SimpleString(arglist)); - if (docstring != null) { + if(arglist != null) + setLambdaList(new SimpleString(arglist)); + if (docstring != null) symbol.setDocumentation(Symbol.FUNCTION, new SimpleString(docstring)); - } - } - - public Function(String name, String arglist) - { - this(name); - setLambdaList(new SimpleString(arglist)); } public Function(String name, Package pkg) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Java.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Java.java Thu Jul 29 15:38:25 2010 @@ -60,11 +60,13 @@ } private static final Primitive ENSURE_JAVA_OBJECT = new pf_ensure_java_object(); + @DocString(name="ensure-java-object", args="obj", + doc="Ensures OBJ is wrapped in a JAVA-OBJECT, wrapping it if necessary.") private static final class pf_ensure_java_object extends Primitive { pf_ensure_java_object() { - super("ensure-java-object", PACKAGE_JAVA, true, "obj"); + super("ensure-java-object", PACKAGE_JAVA, true); } @Override @@ -73,14 +75,16 @@ } }; - // ### register-java-exception exception-name condition-symbol => T private static final Primitive REGISTER_JAVA_EXCEPTION = new pf_register_java_exception(); + @DocString(name="register-java-exception", // => T + args="exception-name condition-symbol", + doc="Registers the Java Throwable named by the symbol EXCEPTION-NAME as the condition " + + "designated by CONDITION-SYMBOL. Returns T if successful, NIL if not.") private static final class pf_register_java_exception extends Primitive { pf_register_java_exception() { - super("register-java-exception", PACKAGE_JAVA, true, - "exception-name condition-symbol"); + super("register-java-exception", PACKAGE_JAVA, true); } @Override @@ -98,14 +102,15 @@ } }; - // ### unregister-java-exception exception-name => T or NIL private static final Primitive UNREGISTER_JAVA_EXCEPTION = new pf_unregister_java_exception(); + @DocString(name="unregister-java-exception", args="exception-name", + doc="Unregisters the Java Throwable EXCEPTION-NAME previously registered" + + " by REGISTER-JAVA-EXCEPTION.") private static final class pf_unregister_java_exception extends Primitive { pf_unregister_java_exception() { - super("unregister-java-exception", PACKAGE_JAVA, true, - "exception-name"); + super("unregister-java-exception", PACKAGE_JAVA, true); } @Override @@ -129,15 +134,17 @@ return null; } - // ### jclass name-or-class-ref &optional class-loader => class-ref private static final Primitive JCLASS = new pf_jclass(); + @DocString(name="jclass", args="name-or-class-ref &optional class-loader", + doc="Returns a reference to the Java class designated by" + + " NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the" + + " class is resolved with respect to the given ClassLoader.") private static final class pf_jclass extends Primitive { pf_jclass() { - super(Symbol.JCLASS, "name-or-class-ref &optional class-loader", - "Returns a reference to the Java class designated by NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the class is resolved with respect to the given ClassLoader."); + super(Symbol.JCLASS); } @Override @@ -154,35 +161,6 @@ } }; - // ### jfield - retrieve or modify a field in a Java class or instance. - // - // Supported argument patterns: - // - // Case 1: class-ref field-name: - // to retrieve the value of a static field. - // - // Case 2: class-ref field-name instance-ref: - // to retrieve the value of a class field of the instance. - // - // Case 3: class-ref field-name primitive-value: - // to store primitive-value in a static field. - // - // Case 4: class-ref field-name instance-ref value: - // to store value in a class field of the instance. - // - // Case 5: class-ref field-name nil value: - // to store value in a static field (when value may be - // confused with an instance-ref). - // - // Case 6: field-name instance: - // to retrieve the value of a field of the instance. The - // class is derived from the instance. - // - // Case 7: field-name instance value: - // to store value in a field of the instance. The class is - // derived from the instance. - // - static final LispObject jfield(Primitive fun, LispObject[] args, boolean translate) { @@ -258,14 +236,35 @@ return NIL; } - // ### jfield class-ref-or-field field-or-instance &optional instance value + private static final Primitive JFIELD = new pf_jfield(); + @DocString(name="jfield", + args="class-ref-or-field field-or-instance &optional instance value", + doc="Retrieves or modifies a field in a Java class or instance.\n\n"+ + "Supported argument patterns:\n\n"+ + " Case 1: class-ref field-name:\n"+ + " Retrieves the value of a static field.\n\n"+ + " Case 2: class-ref field-name instance-ref:\n"+ + " Retrieves the value of a class field of the instance.\n\n"+ + " Case 3: class-ref field-name primitive-value:\n"+ + " Stores a primitive-value in a static field.\n\n"+ + " Case 4: class-ref field-name instance-ref value:\n"+ + " Stores value in a class field of the instance.\n\n"+ + " Case 5: class-ref field-name nil value:\n"+ + " Stores value in a static field (when value may be\n"+ + " confused with an instance-ref).\n\n"+ + " Case 6: field-name instance:\n"+ + " Retrieves the value of a field of the instance. The\n"+ + " class is derived from the instance.\n\n"+ + " Case 7: field-name instance value:\n"+ + " Stores value in a field of the instance. The class is\n"+ + " derived from the instance.\n\n" + ) private static final class pf_jfield extends Primitive { pf_jfield() { - super("jfield", PACKAGE_JAVA, true, - "class-ref-or-field field-or-instance &optional instance value"); + super("jfield", PACKAGE_JAVA, true); } @Override @@ -275,14 +274,35 @@ } }; - // ### jfield-raw - retrieve or modify a field in a Java class or instance. private static final Primitive JFIELD_RAW = new pf_jfield_raw(); + @DocString(name="jfield", + args="class-ref-or-field field-or-instance &optional instance value", + doc="Retrieves or modifies a field in a Java class or instance. Does not\n"+ + "attempt to coerce its value or the result into a Lisp object.\n\n"+ + "Supported argument patterns:\n\n"+ + " Case 1: class-ref field-name:\n"+ + " Retrieves the value of a static field.\n\n"+ + " Case 2: class-ref field-name instance-ref:\n"+ + " Retrieves the value of a class field of the instance.\n\n"+ + " Case 3: class-ref field-name primitive-value:\n"+ + " Stores a primitive-value in a static field.\n\n"+ + " Case 4: class-ref field-name instance-ref value:\n"+ + " Stores value in a class field of the instance.\n\n"+ + " Case 5: class-ref field-name nil value:\n"+ + " Stores value in a static field (when value may be\n"+ + " confused with an instance-ref).\n\n"+ + " Case 6: field-name instance:\n"+ + " Retrieves the value of a field of the instance. The\n"+ + " class is derived from the instance.\n\n"+ + " Case 7: field-name instance value:\n"+ + " Stores value in a field of the instance. The class is\n"+ + " derived from the instance.\n\n" + ) private static final class pf_jfield_raw extends Primitive { pf_jfield_raw() { - super("jfield-raw", PACKAGE_JAVA, true, - "class-ref-or-field field-or-instance &optional instance value"); + super("jfield-raw", PACKAGE_JAVA, true); } @Override @@ -292,14 +312,15 @@ } }; - // ### jconstructor class-ref &rest parameter-class-refs private static final Primitive JCONSTRUCTOR = new pf_jconstructor(); + @DocString(name="jconstructor", args="class-ref &rest parameter-class-refs", + doc="Returns a reference to the Java constructor of CLASS-REF with the" + + " given PARAMETER-CLASS-REFS.") private static final class pf_jconstructor extends Primitive { pf_jconstructor() { - super("jconstructor", PACKAGE_JAVA, true, - "class-ref &rest parameter-class-refs"); + super("jconstructor", PACKAGE_JAVA, true); } @Override @@ -342,14 +363,16 @@ } }; - // ### jmethod class-ref name &rest parameter-class-refs private static final Primitive JMETHOD = new pf_jmethod(); + + @DocString(name="jmethod", args="class-ref method-name &rest parameter-class-refs", + doc="Returns a reference to the Java method METHOD-NAME of CLASS-REF with the" + + " given PARAMETER-CLASS-REFS.") private static final class pf_jmethod extends Primitive { pf_jmethod() { - super("jmethod", PACKAGE_JAVA, true, - "class-ref name &rest parameter-class-refs"); + super("jmethod", PACKAGE_JAVA, true); } @Override @@ -470,13 +493,14 @@ return NIL; } - // ### jstatic method class &rest args private static final Primitive JSTATIC = new pf_jstatic(); + @DocString(name="jstatic", args="method class &rest args", + doc="Invokes the static method METHOD on class CLASS with ARGS.") private static final class pf_jstatic extends Primitive { pf_jstatic() { - super("jstatic", PACKAGE_JAVA, true, "method class &rest args"); + super("jstatic", PACKAGE_JAVA, true); } @Override @@ -486,14 +510,15 @@ } }; - // ### jstatic-raw method class &rest args private static final Primitive JSTATIC_RAW = new pf_jstatic_raw(); + @DocString(name="jstatic-raw", args="method class &rest args", + doc="Invokes the static method METHOD on class CLASS with ARGS. Does not "+ + "attempt to coerce the arguments or result into a Lisp object.") private static final class pf_jstatic_raw extends Primitive { pf_jstatic_raw() { - super("jstatic-raw", PACKAGE_JAVA, true, - "method class &rest args"); + super("jstatic-raw", PACKAGE_JAVA, true); } @Override @@ -503,13 +528,14 @@ } }; - // ### jnew constructor &rest args private static final Primitive JNEW = new pf_jnew(); + @DocString(name="jnew", args="constructor &rest args", + doc="Invokes the Java constructor CONSTRUCTOR with the arguments ARGS.") private static final class pf_jnew extends Primitive { pf_jnew() { - super("jnew", PACKAGE_JAVA, true, "constructor &rest args"); + super("jnew", PACKAGE_JAVA, true); } @Override @@ -523,7 +549,14 @@ if(classRef instanceof AbstractString) { constructor = findConstructor(javaClass(classRef), args); } else { - constructor = (Constructor) JavaObject.getObject(classRef); + Object object = JavaObject.getObject(classRef); + if(object instanceof Constructor) { + constructor = (Constructor) object; + } else if(object instanceof Class) { + constructor = findConstructor((Class) object, args); + } else { + return error(new LispError(classRef.writeToString() + " is neither a Constructor nor a Class")); + } } Class[] argTypes = constructor.getParameterTypes(); Object[] initargs = new Object[args.length-1]; @@ -559,14 +592,15 @@ } }; - // ### jnew-array element-type &rest dimensions private static final Primitive JNEW_ARRAY = new pf_jnew_array(); + @DocString(name="jnew-array", args="element-type &rest dimensions", + doc="Creates a new Java array of type ELEMENT-TYPE, with the given" + + " DIMENSIONS.") private static final class pf_jnew_array extends Primitive { pf_jnew_array() { - super("jnew-array", PACKAGE_JAVA, true, - "element-type &rest dimensions"); + super("jnew-array", PACKAGE_JAVA, true); } @Override @@ -617,14 +651,15 @@ return NIL; } - // ### jarray-ref java-array &rest indices private static final Primitive JARRAY_REF = new pf_jarray_ref(); + @DocString(name="jarray-ref", args="java-array &rest indices", + doc="Dereferences the Java array JAVA-ARRAY using the given INDICIES, " + + "coercing the result into a Lisp object, if possible.") private static final class pf_jarray_ref extends Primitive { pf_jarray_ref() { - super("jarray-ref", PACKAGE_JAVA, true, - "java-array &rest indices"); + super("jarray-ref", PACKAGE_JAVA, true); } @Override @@ -634,14 +669,15 @@ } }; - // ### jarray-ref-raw java-array &rest indices private static final Primitive JARRAY_REF_RAW = new pf_jarray_ref_raw(); + @DocString(name="jarray-ref-raw", args="java-array &rest indices", + doc="Dereference the Java array JAVA-ARRAY using the given INDICIES. " + + "Does not attempt to coerce the result into a Lisp object.") private static final class pf_jarray_ref_raw extends Primitive { pf_jarray_ref_raw() { - super("jarray-ref-raw", PACKAGE_JAVA, true, - "java-array &rest indices"); + super("jarray-ref-raw", PACKAGE_JAVA, true); } @Override @@ -651,14 +687,14 @@ } }; - // ### jarray-set java-array new-value &rest indices private static final Primitive JARRAY_SET = new pf_jarray_set(); + @DocString(name="jarray-set", args="java-array new-value &rest indices", + doc="Stores NEW-VALUE at the given index in JAVA-ARRAY.") private static final class pf_jarray_set extends Primitive { pf_jarray_set() { - super("jarray-set", PACKAGE_JAVA, true, - "java-array new-value &rest indices"); + super("jarray-set", PACKAGE_JAVA, true); } @Override @@ -691,14 +727,16 @@ } }; - // ### jcall method instance &rest args /** Calls makeLispObject() to convert the result to an appropriate Lisp type. */ private static final Primitive JCALL = new pf_jcall(); + @DocString(name="jcall", args="method-ref instance &rest args", + doc="Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS," + + " coercing the result into a Lisp object, if possible.") private static final class pf_jcall extends Primitive { pf_jcall() { - super(Symbol.JCALL, "method-ref instance &rest args"); + super(Symbol.JCALL); } @Override @@ -708,17 +746,19 @@ } }; - // ### jcall-raw method instance &rest args /** * Does no type conversion. The result of the call is simply wrapped in a * JavaObject. */ private static final Primitive JCALL_RAW = new pf_jcall_raw(); + @DocString(name="jcall-raw", args="method-ref instance &rest args", + doc="Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS." + + " Does not attempt to coerce the result into a Lisp object.") private static final class pf_jcall_raw extends Primitive { pf_jcall_raw() { - super(Symbol.JCALL_RAW, "method-ref instance &rest args"); + super(Symbol.JCALL_RAW); } @Override @@ -976,14 +1016,17 @@ } } - // ### make-immediate-object object &optional type private static final Primitive MAKE_IMMEDIATE_OBJECT = new pf_make_immediate_object(); + @DocString(name="make-immediate-object", args="object &optional type", + doc="Attempts to coerce a given Lisp object into a java-object of the\n"+ + "given type. If type is not provided, works as jobject-lisp-value.\n"+ + "Currently, type may be :BOOLEAN, treating the object as a truth value,\n"+ + "or :REF, which returns Java null if NIL is provided.") private static final class pf_make_immediate_object extends Primitive { pf_make_immediate_object() { - super("make-immediate-object", PACKAGE_JAVA, true, - "object &optional type"); + super("make-immediate-object", PACKAGE_JAVA, true); } @Override @@ -1012,13 +1055,14 @@ } }; - // ### java-object-p private static final Primitive JAVA_OBJECT_P = new pf_java_object_p(); + @DocString(name="java-object-p", args="object", + doc="Returns T if OBJECT is a JAVA-OBJECT.") private static final class pf_java_object_p extends Primitive { pf_java_object_p() { - super("java-object-p", PACKAGE_JAVA, true, "object"); + super("java-object-p", PACKAGE_JAVA, true); } @Override @@ -1028,8 +1072,9 @@ } }; - // ### jobject-lisp-value java-object private static final Primitive JOBJECT_LISP_VALUE = new pf_jobject_lisp_value(); + @DocString(name="jobject-lisp-value", args="java-object", + doc="Attempts to coerce JAVA-OBJECT into a Lisp object.") private static final class pf_jobject_lisp_value extends Primitive { pf_jobject_lisp_value() @@ -1044,13 +1089,15 @@ } }; - // ### jcoerce java-object intended-class private static final Primitive JCOERCE = new pf_jcoerce(); + @DocString(name="jcoerce", args="object intended-class", + doc="Attempts to coerce OBJECT into a JavaObject of class INTENDED-CLASS." + + " Raises a TYPE-ERROR if no conversion is possible.") private static final class pf_jcoerce extends Primitive { pf_jcoerce() { - super("jcoerce", PACKAGE_JAVA, true, "java-object intended-class"); + super("jcoerce", PACKAGE_JAVA, true); } @Override @@ -1066,8 +1113,10 @@ } }; - // ### %jget-property-value java-object property-name private static final Primitive JGET_PROPERTY_VALUE = new pf__jget_property_value(); + @DocString(name="%jget-propety-value", args="java-object property-name", + doc="Gets a JavaBeans property on JAVA-OBJECT.\n" + + "SYSTEM-INTERNAL: Use jproperty-value instead.") private static final class pf__jget_property_value extends Primitive { pf__jget_property_value() @@ -1095,8 +1144,10 @@ } }; - // ### %jset-property-value java-object property-name value private static final Primitive JSET_PROPERTY_VALUE = new pf__jset_property_value(); + @DocString(name="%jset-propety-value", args="java-object property-name value", + doc="Sets a JavaBean property on JAVA-OBJECT.\n" + + "SYSTEM-INTERNAL: Use (setf jproperty-value) instead.") private static final class pf__jset_property_value extends Primitive { pf__jset_property_value() @@ -1131,15 +1182,15 @@ } }; - - // ### jrun-exception-protected closure private static final Primitive JRUN_EXCEPTION_PROTECTED = new pf_jrun_exception_protection(); + @DocString(name="jrun-exception-protected", args="closure", + doc="Invokes the function CLOSURE and returns the result. "+ + "Signals an error if stack or heap exhaustion occurs.") private static final class pf_jrun_exception_protection extends Primitive { pf_jrun_exception_protection() { - super("jrun-exception-protected", PACKAGE_JAVA, true, - "closure"); + super("jrun-exception-protected", PACKAGE_JAVA, true); } @Override Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaObject.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/JavaObject.java Thu Jul 29 15:38:25 2010 @@ -97,18 +97,31 @@ return T; if (type == BuiltInClass.JAVA_OBJECT) return T; - if(type.typep(LispClass.findClass(JAVA_CLASS, false)) != NIL) { + LispObject cls = NIL; + if(type instanceof Symbol) { + cls = LispClass.findClass(type, false); + } + if(cls == NIL) { + cls = type; + } + if(cls.typep(LispClass.findClass(JAVA_CLASS, false)) != NIL) { if(obj != null) { - Class c = (Class) JAVA_CLASS_JCLASS.execute(type).javaInstance(); + Class c = (Class) JAVA_CLASS_JCLASS.execute(cls).javaInstance(); return c.isAssignableFrom(obj.getClass()) ? T : NIL; } else { return T; } + } else if(cls == BuiltInClass.SEQUENCE) { + //This information is replicated here from java.lisp; it is a very + //specific case, not worth implementing CPL traversal in typep + if(java.util.List.class.isInstance(obj) || + java.util.Set.class.isInstance(obj)) { + return T; + } } return super.typep(type); } - @Override public LispObject STRING() { Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Lisp.java Thu Jul 29 15:38:25 2010 @@ -89,7 +89,7 @@ Packages.createPackage("SEQUENCE"); - // ### nil + @DocString(name="nil") public static final LispObject NIL = Nil.NIL; // We need NIL before we can call usePackage(). @@ -261,7 +261,7 @@ return thread.setValues(form, NIL); } - // ### interactive-eval + @DocString(name="interactive-eval") private static final Primitive INTERACTIVE_EVAL = new Primitive("interactive-eval", PACKAGE_SYS, true) { Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/LispObject.java Thu Jul 29 15:38:25 2010 @@ -657,6 +657,23 @@ if (entry instanceof Cons) return ((Cons)entry).cdr; } + if(docType == Symbol.FUNCTION && this instanceof Symbol) { + Object fn = ((Symbol)this).getSymbolFunction(); + if(fn instanceof Function) { + DocString ds = fn.getClass().getAnnotation(DocString.class); + if(ds != null) { + String arglist = ds.args(); + String docstring = ds.doc(); + if(arglist.length() != 0) + ((Function)fn).setLambdaList(new SimpleString(arglist)); + if(docstring.length() != 0) { + SimpleString doc = new SimpleString(docstring); + ((Symbol)this).setDocumentation(Symbol.FUNCTION, doc); + return doc; + } + } + } + } return NIL; } Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/LispThread.java Thu Jul 29 15:38:25 2010 @@ -860,7 +860,7 @@ return unreadableString(sb.toString()); } - // ### make-thread + @DocString(name="make-thread", args="function &optional &key name") private static final Primitive MAKE_THREAD = new Primitive("make-thread", PACKAGE_THREADS, true, "function &optional &key name") { @@ -886,10 +886,10 @@ } }; - // ### threadp + @DocString(name="threadp", args="object", + doc="Boolean predicate testing if OBJECT is a thread.") private static final Primitive THREADP = - new Primitive("threadp", PACKAGE_THREADS, true, "object", - "Boolean predicate as whether OBJECT is a thread.") + new Primitive("threadp", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject arg) @@ -898,7 +898,8 @@ } }; - // ### thread-alive-p + @DocString(name="thread-alive-p", args="thread", + doc="Returns T if THREAD is alive.") private static final Primitive THREAD_ALIVE_P = new Primitive("thread-alive-p", PACKAGE_THREADS, true, "thread", "Boolean predicate whether THREAD is alive.") @@ -917,10 +918,10 @@ } }; - // ### thread-name + @DocString(name="thread-name", args="thread", + doc="Return the name of THREAD, if it has one.") private static final Primitive THREAD_NAME = - new Primitive("thread-name", PACKAGE_THREADS, true, "thread", - "Return the name of THREAD if it has one.") + new Primitive("thread-name", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject arg) @@ -972,9 +973,10 @@ return (d < Long.MAX_VALUE ? (long) d : Long.MAX_VALUE); } - // ### sleep - private static final Primitive SLEEP = new Primitive("sleep", PACKAGE_CL, true, "seconds", - "Causes the invoking thread to sleep for SECONDS seconds.\nSECONDS may be a value between 0 1and 1.") + @DocString(name="sleep", args="seconds", + doc="Causes the invoking thread to sleep for SECONDS seconds.\n"+ + "SECONDS may be a value between 0 1and 1.") + private static final Primitive SLEEP = new Primitive("sleep", PACKAGE_CL, true) { @Override public LispObject execute(LispObject arg) @@ -990,10 +992,10 @@ } }; - // ### mapcar-threads + @DocString(name="mapcar-threads", args= "function", + doc="Applies FUNCTION to all existing threads.") private static final Primitive MAPCAR_THREADS = - new Primitive("mapcar-threads", PACKAGE_THREADS, true, "function", - "Applies FUNCTION to all existing threads.") + new Primitive("mapcar-threads", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject arg) @@ -1011,10 +1013,9 @@ } }; - // ### destroy-thread + @DocString(name="destroy-thread", args="thread", doc="Mark THREAD as destroyed") private static final Primitive DESTROY_THREAD = - new Primitive("destroy-thread", PACKAGE_THREADS, true, "thread", - "Mark THREAD as destroyed.") + new Primitive("destroy-thread", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject arg) @@ -1031,11 +1032,12 @@ } }; - // ### interrupt-thread thread function &rest args => T - // Interrupts thread and forces it to apply function to args. When the - // function returns, the thread's original computation continues. If - // multiple interrupts are queued for a thread, they are all run, but the - // order is not guaranteed. + // => T + @DocString(name="interrupt-thread", args="thread function &rest args", + doc="Interrupts thread and forces it to apply function to args. When the\n"+ + "function returns, the thread's original computation continues. If\n"+ + "multiple interrupts are queued for a thread, they are all run, but the\n"+ + "order is not guaranteed.") private static final Primitive INTERRUPT_THREAD = new Primitive("interrupt-thread", PACKAGE_THREADS, true, "thread function &rest args", @@ -1062,10 +1064,10 @@ } }; - // ### current-thread + @DocString(name="current-thread", + doc="Returns a reference to invoking thread.") private static final Primitive CURRENT_THREAD = - new Primitive("current-thread", PACKAGE_THREADS, true, "", - "Returns a reference to invoking thread.") + new Primitive("current-thread", PACKAGE_THREADS, true) { @Override public LispObject execute() @@ -1074,10 +1076,10 @@ } }; - // ### backtrace + @DocString(name="backtrace", + doc="Returns a backtrace of the invoking thread.") private static final Primitive BACKTRACE = - new Primitive("backtrace", PACKAGE_SYS, true, "", - "Returns a backtrace of the invoking thread.") + new Primitive("backtrace", PACKAGE_SYS, true) { @Override public LispObject execute(LispObject[] args) @@ -1089,9 +1091,9 @@ return currentThread().backtrace(limit); } }; - // ### frame-to-string + @DocString(name="frame-to-string", args="frame") private static final Primitive FRAME_TO_STRING = - new Primitive("frame-to-string", PACKAGE_SYS, true, "frame") + new Primitive("frame-to-string", PACKAGE_SYS, true) { @Override public LispObject execute(LispObject[] args) @@ -1104,9 +1106,9 @@ } }; - // ### frame-to-list + @DocString(name="frame-to-list", args="frame") private static final Primitive FRAME_TO_LIST = - new Primitive("frame-to-list", PACKAGE_SYS, true, "frame") + new Primitive("frame-to-list", PACKAGE_SYS, true) { @Override public LispObject execute(LispObject[] args) @@ -1120,20 +1122,7 @@ }; - static { - //FIXME: this block has been added for pre-0.16 compatibility - // and can be removed the latest at release 0.22 - PACKAGE_EXT.export(intern("MAKE-THREAD", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("THREADP", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("THREAD-ALIVE-P", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("THREAD-NAME", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("MAPCAR-THREADS", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("DESTROY-THREAD", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("INTERRUPT-THREAD", PACKAGE_THREADS)); - PACKAGE_EXT.export(intern("CURRENT-THREAD", PACKAGE_THREADS)); - } - - // ### use-fast-calls + @DocString(name="use-fast-calls") private static final Primitive USE_FAST_CALLS = new Primitive("use-fast-calls", PACKAGE_SYS, true) { @@ -1145,7 +1134,7 @@ } }; - // ### synchronized-on + @DocString(name="synchronized-on", args="form &body body") private static final SpecialOperator SYNCHRONIZED_ON = new SpecialOperator("synchronized-on", PACKAGE_THREADS, true, "form &body body") @@ -1164,10 +1153,9 @@ } }; - // ### object-wait + @DocString(name="object-wait", args="object &optional timeout") private static final Primitive OBJECT_WAIT = - new Primitive("object-wait", PACKAGE_THREADS, true, - "object &optional timeout") + new Primitive("object-wait", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject object) @@ -1202,7 +1190,7 @@ } }; - // ### object-notify + @DocString(name="object-notify", args="object") private static final Primitive OBJECT_NOTIFY = new Primitive("object-notify", PACKAGE_THREADS, true, "object") @@ -1221,10 +1209,9 @@ } }; - // ### object-notify-all + @DocString(name="object-notify-all", args="object") private static final Primitive OBJECT_NOTIFY_ALL = - new Primitive("object-notify-all", PACKAGE_THREADS, true, - "object") + new Primitive("object-notify-all", PACKAGE_THREADS, true) { @Override public LispObject execute(LispObject object) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Operator.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Operator.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Operator.java Thu Jul 29 15:38:25 2010 @@ -53,6 +53,11 @@ public final LispObject getLambdaList() { + if(lambdaList == null) { + DocString ds = getClass().getAnnotation(DocString.class); + if(ds != null) + lambdaList = new SimpleString(ds.args()); + } return lambdaList; } Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Pathname.java Thu Jul 29 15:38:25 2010 @@ -860,6 +860,7 @@ useNamestring = false; } StringBuilder sb = new StringBuilder(); + if (useNamestring) { if (printReadably || printEscape) { sb.append("#P\""); @@ -877,61 +878,45 @@ if (printReadably || printEscape) { sb.append('"'); } - } else { - final SpecialBindingsMark mark = thread.markSpecialBindings(); - thread.bindSpecial(Symbol.PRINT_ESCAPE, T); - try { - final boolean ANSI_COMPATIBLE = true; - final String SPACE = " "; - if (ANSI_COMPATIBLE) { - sb.append("#P(\""); - } else { - sb.append("#P("); + return sb.toString(); + } - } - if (host != NIL) { - sb.append(":HOST "); - sb.append(host.writeToString()); - sb.append(SPACE); - } - if (device != NIL) { - sb.append(":DEVICE "); - sb.append(device.writeToString()); - sb.append(SPACE); - } - if (directory != NIL) { - sb.append(":DIRECTORY "); - sb.append(directory.writeToString()); - sb.append(SPACE); - } - if (name != NIL) { - sb.append(":NAME "); - sb.append(name.writeToString()); - sb.append(SPACE); - } - if (type != NIL) { - sb.append(":TYPE "); - sb.append(type.writeToString()); - sb.append(SPACE); - } - if (version != NIL) { - sb.append(":VERSION "); - sb.append(version.writeToString()); - sb.append(SPACE); - } - if (sb.charAt(sb.length() - 1) == ' ') { // XXX - sb.setLength(sb.length() - 1); - } - if (ANSI_COMPATIBLE) { - sb.append(')' + "\""); - } else { - sb.append(')'); - } - } finally { - thread.resetSpecialBindings(mark); - } + sb.append("PATHNAME (with no namestring) "); + if (host != NIL) { + sb.append(":HOST "); + sb.append(host.writeToString()); + sb.append(" "); } - return sb.toString(); + if (device != NIL) { + sb.append(":DEVICE "); + sb.append(device.writeToString()); + sb.append(" "); + } + if (directory != NIL) { + sb.append(":DIRECTORY "); + sb.append(directory.writeToString()); + sb.append(" "); + } + if (name != NIL) { + sb.append(":NAME "); + sb.append(name.writeToString()); + sb.append(" "); + } + if (type != NIL) { + sb.append(":TYPE "); + sb.append(type.writeToString()); + sb.append(" "); + } + if (version != NIL) { + sb.append(":VERSION "); + sb.append(version.writeToString()); + sb.append(" "); + } + if (sb.charAt(sb.length() - 1) == ' ') { + sb.setLength(sb.length() - 1); + } + + return unreadableString(sb.toString()); } // A logical host is represented as the string that names it. // (defvar *logical-pathname-translations* (make-hash-table :test 'equal)) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitive.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitive.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitive.java Thu Jul 29 15:38:25 2010 @@ -45,6 +45,11 @@ super(name); } + public Primitive(Symbol symbol) + { + super(symbol); + } + public Primitive(Symbol symbol, String arglist) { super(symbol, arglist); Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Primitives.java Thu Jul 29 15:38:25 2010 @@ -890,7 +890,16 @@ out = Symbol.STANDARD_OUTPUT.symbolValue(); else out = second; - checkStream(out)._writeString(first.writeToString()); + String output = first.writeToString(); + if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL + && output.contains("#<")) { + LispObject args = NIL; + args = args.push(first); + args = args.push(Keyword.OBJECT); + args = args.nreverse(); + return error(new PrintNotReadable(args)); + } + checkStream(out)._writeString(output); return first; } }; Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Stream.java Thu Jul 29 15:38:25 2010 @@ -534,11 +534,12 @@ public LispObject readPathname(ReadtableAccessor rta) { LispObject obj = read(true, NIL, false, LispThread.currentThread(), rta); - if (obj instanceof AbstractString) + if (obj instanceof AbstractString) { return Pathname.parseNamestring((AbstractString)obj); + } if (obj.listp()) return Pathname.makePathname(obj); - return error(new TypeError("#p requires a string or list argument.")); + return error(new TypeError("#p requires a string argument.")); } public LispObject readSymbol() { Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/Version.java Thu Jul 29 15:38:25 2010 @@ -41,9 +41,9 @@ public static String getVersion() { - return "0.21.0-dev"; + return "0.22.0-dev"; } - + public static void main(String args[]) { System.out.println(Version.getVersion()); } Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/asdf.lisp Thu Jul 29 15:38:25 2010 @@ -70,7 +70,7 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105. + (subseq "VERSION:2.004" (1+ (length "VERSION")))) ; NB: same as 2.111. (existing-asdf (find-package :asdf)) (vername '#:*asdf-version*) (versym (and existing-asdf @@ -727,8 +727,12 @@ #+clisp (defun get-uid () (posix:uid)) #+sbcl (defun get-uid () (sb-unix:unix-getuid)) #+cmu (defun get-uid () (unix:unix-getuid)) -#+ecl (ffi:clines "#include " "#include ") -#+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t)) +#+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) + '(ffi:clines "#include " "#include ")) +#+ecl (defun get-uid () + #.(cl:if (cl:< ext:+ecl-version-number+ 100601) + '(ffi:c-inline () () :int "getuid()" :one-liner t) + '(ext::getuid))) #+allegro (defun get-uid () (excl.osi:getuid)) #-(or cmu sbcl clisp allegro ecl) (defun get-uid () @@ -1073,6 +1077,17 @@ (defun system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) +(defun clear-system (name) + "Clear the entry for a system in the database of systems previously loaded. +Note that this does NOT in any way cause the code of the system to be unloaded." + ;; There is no "unload" operation in Common Lisp, and a general such operation + ;; cannot be portably written, considering how much CL relies on side-effects + ;; of global data structures. + ;; Note that this does a setf gethash instead of a remhash + ;; this way there remains a hint in the *defined-systems* table + ;; that the system was loaded at some point. + (setf (gethash (coerce-name name) *defined-systems*) nil)) + (defun map-systems (fn) "Apply FN to each defined system. @@ -2395,6 +2410,7 @@ :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc :java-1.4 :java-1.5 :java-1.6 :java-1.7)) + (defun lisp-version-string () (let ((s (lisp-implementation-version))) (declare (ignorable s)) @@ -2410,6 +2426,7 @@ (:-ics "8") (:+ics "")) (if (member :64bit *features*) "-64bit" "")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) #+clisp (subseq s 0 (position #\space s)) #+clozure (format nil "~d.~d-fasl~d" ccl::*openmcl-major-version* @@ -2424,8 +2441,7 @@ #+gcl (subseq s (1+ (position #\space s))) #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")) - ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant - #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version #+(or cormanlisp mcl sbcl scl) s #-(or allegro armedbear clisp clozure cmu cormanlisp digitool ecl gcl lispworks mcl sbcl scl) s)) @@ -2510,7 +2526,7 @@ `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) - (list #p"/etc/")))) + (list #p"/etc/common-lisp/")))) (defun in-first-directory (dirs x) (loop :for dir :in dirs :thereis (and dir (ignore-errors @@ -2957,7 +2973,7 @@ :defaults x)) (defun delete-file-if-exists (x) - (when (probe-file x) + (when (and x (probe-file x)) (delete-file x))) (defun compile-file* (input-file &rest keys &key &allow-other-keys) @@ -3354,14 +3370,18 @@ (defun initialize-source-registry (&optional parameter) (setf (source-registry) (compute-source-registry parameter))) -;; checks an initial variable to see whether the state is initialized +;; Checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in ;; the latter, initialize. ASDF will call this function at the start -;; of (asdf:find-system). -(defun ensure-source-registry () +;; of (asdf:find-system) to make sure the source registry is initialized. +;; However, it will do so *without* a parameter, at which point it +;; will be too late to provide a parameter to this function, though +;; you may override the configuration explicitly by calling +;; initialize-source-registry directly with your parameter. +(defun ensure-source-registry (&optional parameter) (if (source-registry-initialized-p) (source-registry) - (initialize-source-registry))) + (initialize-source-registry parameter))) (defun sysdef-source-registry-search (system) (ensure-source-registry) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Jul 29 15:38:25 2010 @@ -345,16 +345,6 @@ (export '(make-thread-lock thread-lock thread-unlock with-thread-lock)) (export '(make-mutex get-mutex release-mutex with-mutex)) -(progn - ;; block to be removed at 0.22 - ;; It exists solely for pre-0.17 compatibility - ;; FIXME 0.22 - (in-package "EXTENSIONS") - (export '(mailbox-send mailbox-empty-p mailbox-read mailbox-peek)) - (export '(make-thread-lock thread-lock thread-unlock with-thread-lock)) - (export '(with-mutex make-mutex get-mutex release-mutex))) - -;; end of 0.22 block (in-package "EXTENSIONS") @@ -428,6 +418,8 @@ (in-package "COMMON-LISP") +(sys::autoload '(documentation) "clos") + (sys::autoload '(write print prin1 princ pprint write-to-string prin1-to-string princ-to-string write-char write-string write-line terpri finish-output Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp Thu Jul 29 15:38:25 2010 @@ -187,6 +187,7 @@ "inspect.lisp" ;;"j.lisp" "java.lisp" + "java-collections.lisp" "known-functions.lisp" "known-symbols.lisp" "late-setf.lisp" Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/debug.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/debug.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/debug.lisp Thu Jul 29 15:38:25 2010 @@ -85,7 +85,8 @@ (when condition (fresh-line *debug-io*) (with-standard-io-syntax - (let ((*print-structure* nil)) + (let ((*print-structure* nil) + (*print-readably* nil)) (when (and *load-truename* (streamp *load-stream*)) (simple-format *debug-io* "Error loading ~A at line ~D (offset ~D)~%" Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/java.lisp Thu Jul 29 15:38:25 2010 @@ -149,6 +149,11 @@ method implementation))))) lisp-this)) +(defun jequal (obj1 obj2) + "Compares obj1 with obj2 using java.lang.Object.equals()" + (jcall (jmethod "java.lang.Object" "equals" "java.lang.Object") + obj1 obj2)) + (defun jobject-class (obj) "Returns the Java class that OBJ belongs to" (jcall (jmethod "java.lang.Object" "getClass") obj)) @@ -363,6 +368,15 @@ :direct-superclasses (list (find-class 'java-object)) :java-class +java-lang-object+))) +(defun jclass-additional-superclasses (jclass) + "Extension point to put additional CLOS classes on the CPL of a CLOS Java class." + (let ((supers nil)) + (when (jclass-interface-p jclass) + (push (find-class 'java-object) supers)) + (when (jequal jclass (jclass "java.util.List")) + (push (find-class 'sequence) supers)) + supers)) + (defun ensure-java-class (jclass) (let ((class (%find-java-class jclass))) (if class @@ -378,9 +392,7 @@ (concatenate 'list (list (jclass-superclass jclass)) (jclass-interfaces jclass)))))) - (if (jclass-interface-p jclass) - (append supers (list (find-class 'java-object))) - supers)) + (append supers (jclass-additional-superclasses jclass))) :java-class jclass))))) (defmethod mop::compute-class-precedence-list ((class java-class)) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/logorc2.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/logorc2.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/logorc2.java Thu Jul 29 15:38:25 2010 @@ -37,9 +37,9 @@ import java.math.BigInteger; -// ### logorc2 // logorc2 integer-1 integer-2 => result-integer // or integer-1 with complement of integer-2 + at DocString(name="logorc2", args="integer-1 integer-2") public final class logorc2 extends Primitive { private logorc2() Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/package_error_package.java ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/package_error_package.java (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/package_error_package.java Thu Jul 29 15:38:25 2010 @@ -35,7 +35,7 @@ import static org.armedbear.lisp.Lisp.*; -// ### package-error-package + at DocString(name="package-error-package") public final class package_error_package extends Primitive { private package_error_package() Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/print.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/print.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/print.lisp Thu Jul 29 15:38:25 2010 @@ -280,6 +280,10 @@ (symbol-package x)))) (defun %print-object (object stream) + (when (and *print-readably* + (typep object 'string) + (search "#<" object)) + (error 'print-not-readable :object object)) (if *print-pretty* (xp::output-pretty-object object stream) (output-ugly-object object stream))) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/threads.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/threads.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/threads.lisp Thu Jul 29 15:38:25 2010 @@ -1,6 +1,6 @@ ;;; threads.lisp ;;; -;;; Copyright (C) 2009 Erik Huelsmann +;;; Copyright (C) 2009-2010 Erik Huelsmann ;;; ;;; $Id$ ;;; @@ -142,9 +142,3 @@ (synchronized-on ,glock , at body)))) -(defun thread-lock (lock) - "Deprecated; due for removal in 0.22" - (declare (ignore lock))) -(defun thread-unlock (lock) - "Deprecated; due for removal in 0.22" - (declare (ignore lock))) Modified: branches/generic-class-file/abcl/test/lisp/ansi/package.lisp ============================================================================== --- branches/generic-class-file/abcl/test/lisp/ansi/package.lisp (original) +++ branches/generic-class-file/abcl/test/lisp/ansi/package.lisp Thu Jul 29 15:38:25 2010 @@ -32,13 +32,22 @@ (format t "---> ~A begins.~%" message) (format t "Invoking ABCL hosted on ~A ~A.~%" (software-type) (software-version)) - (if (find :unix *features*) - (run-shell-command "cd ~A; make clean" ansi-tests-directory) - ;; XXX -- what to invoke on win32? Untested: - (run-shell-command - (format nil "~A~%~A" - (format nil "cd ~A" *ansi-tests-directory*) - (format nil "erase *.cls *.abcl")))) + ;; Do what 'make clean' would do from the GCL ANSI tests, + ;; so we don't have to hunt for 'make' on win32. + (mapcar #'delete-file + (append (directory (format nil "~A/*.cls" *default-pathname-defaults*)) + (directory (format nil "~A/*.abcl" *default-pathname-defaults*)) + (directory (format nil "~A/scratch/*" *default-pathname-defaults*)) + (mapcar (lambda(x) (format nil "~A/~A" *default-pathname-defaults* x)) + '("scratch/" + "scratch.txt" "foo.txt" "foo.lsp" + "foo.dat" + "tmp.txt" "tmp.dat" "tmp2.dat" + "temp.dat" "out.class" + "file-that-was-renamed.txt" + "compile-file-test-lp.lsp" + "compile-file-test-lp.out" + "ldtest.lsp")))) (time (load boot-file)) (format t "<--- ~A ends.~%" message)) (file-error (e) Modified: branches/generic-class-file/abcl/test/lisp/ansi/parse-ansi-errors.lisp ============================================================================== --- branches/generic-class-file/abcl/test/lisp/ansi/parse-ansi-errors.lisp (original) +++ branches/generic-class-file/abcl/test/lisp/ansi/parse-ansi-errors.lisp Thu Jul 29 15:38:25 2010 @@ -74,7 +74,9 @@ (getf `(doit ,*doit* compileit ,*compileit*) test)) (defvar *default-database-file* - (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*))) + (if (find :asdf2 *features*) + (asdf:system-relative-pathname :ansi-compiled "test/lisp/ansi/ansi-test-failures") + (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*))) (defun parse (&optional (file *default-database-file*)) (format t "Parsing test report database from ~A~%" *default-database-file*) From ehuelsmann at common-lisp.net Sat Jul 31 11:30:15 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 31 Jul 2010 07:30:15 -0400 Subject: [armedbear-cvs] r12835 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 31 07:30:12 2010 New Revision: 12835 Log: Remove code section marked 'Just an experiment': we have supported inlining quite well for some time now. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Jul 31 07:30:12 2010 @@ -476,22 +476,6 @@ (defparameter *descriptors* (make-hash-table :test #'equal)) -;; Just an experiment... -(defmacro defsubst (name lambda-list &rest body) - (let* ((block-name (fdefinition-block-name name)) - (expansion (generate-inline-expansion block-name lambda-list body))) - `(progn - (%defun ',name (lambda ,lambda-list (block ,block-name , at body))) - (precompile ',name) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (inline-expansion ',name) ',expansion)) - ',name))) - -#+nil -(defmacro defsubst (&rest args) - `(defun , at args)) - - (declaim (ftype (function (t t) cons) get-descriptor-info)) (defun get-descriptor-info (arg-types return-type) (let* ((key (list arg-types return-type)) @@ -501,7 +485,8 @@ (or descriptor-info (setf (gethash key ht) (make-descriptor-info arg-types return-type))))) -(defsubst get-descriptor (arg-types return-type) +(declaim (inline get-descriptor)) +(defun get-descriptor (arg-types return-type) (car (get-descriptor-info arg-types return-type))) (declaim (ftype (function * t) emit-invokestatic)) From ehuelsmann at common-lisp.net Sat Jul 31 12:24:53 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 31 Jul 2010 08:24:53 -0400 Subject: [armedbear-cvs] r12836 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 31 08:24:51 2010 New Revision: 12836 Log: Move emit-invoke* functions closer together, making them a section. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Jul 31 08:24:51 2010 @@ -494,9 +494,52 @@ (let* ((info (get-descriptor-info arg-types return-type)) (descriptor (car info)) (stack-effect (cdr info)) - (instruction (emit 'invokestatic class-name method-name descriptor))) + (index (pool-method class-name method-name descriptor)) + (instruction (apply #'%emit 'invokestatic (u2 index)))) (setf (instruction-stack instruction) stack-effect))) + + +(declaim (ftype (function t string) pretty-java-class)) +(defun pretty-java-class (class) + (cond ((equal class +lisp-object-class+) + "LispObject") + ((equal class +lisp-symbol+) + "Symbol") + ((equal class +lisp-thread-class+) + "LispThread") + (t + class))) + +(defknown emit-invokevirtual (t t t t) t) +(defun emit-invokevirtual (class-name method-name arg-types return-type) + (let* ((info (get-descriptor-info arg-types return-type)) + (descriptor (car info)) + (stack-effect (cdr info)) + (index (pool-method class-name method-name descriptor)) + (instruction (apply #'%emit 'invokevirtual (u2 index)))) + (declare (type (signed-byte 8) stack-effect)) + (let ((explain *explain*)) + (when (and explain (memq :java-calls explain)) + (unless (string= method-name "execute") + (format t "; call to ~A ~A.~A(~{~A~^,~})~%" + (pretty-java-type return-type) + (pretty-java-class class-name) + method-name + (mapcar 'pretty-java-type arg-types))))) + (setf (instruction-stack instruction) (1- stack-effect)))) + +(defknown emit-invokespecial-init (string list) t) +(defun emit-invokespecial-init (class-name arg-types) + (let* ((info (get-descriptor-info arg-types nil)) + (descriptor (car info)) + (stack-effect (cdr info)) + (index (pool-method class-name "" descriptor)) + (instruction (apply #'%emit 'invokespecial (u2 index)))) + (declare (type (signed-byte 8) stack-effect)) + (setf (instruction-stack instruction) (1- stack-effect)))) + + (defknown pretty-java-type (t) string) (defun pretty-java-type (type) (let ((arrayp nil) @@ -660,44 +703,6 @@ (return-from common-representation result))))) - -(declaim (ftype (function t string) pretty-java-class)) -(defun pretty-java-class (class) - (cond ((equal class +lisp-object-class+) - "LispObject") - ((equal class +lisp-symbol+) - "Symbol") - ((equal class +lisp-thread-class+) - "LispThread") - (t - class))) - -(defknown emit-invokevirtual (t t t t) t) -(defun emit-invokevirtual (class-name method-name arg-types return-type) - (let* ((info (get-descriptor-info arg-types return-type)) - (descriptor (car info)) - (stack-effect (cdr info)) - (instruction (emit 'invokevirtual class-name method-name descriptor))) - (declare (type (signed-byte 8) stack-effect)) - (let ((explain *explain*)) - (when (and explain (memq :java-calls explain)) - (unless (string= method-name "execute") - (format t "; call to ~A ~A.~A(~{~A~^,~})~%" - (pretty-java-type return-type) - (pretty-java-class class-name) - method-name - (mapcar 'pretty-java-type arg-types))))) - (setf (instruction-stack instruction) (1- stack-effect)))) - -(defknown emit-invokespecial-init (string list) t) -(defun emit-invokespecial-init (class-name arg-types) - (let* ((info (get-descriptor-info arg-types nil)) - (descriptor (car info)) - (stack-effect (cdr info)) - (instruction (emit 'invokespecial class-name "" descriptor))) - (declare (type (signed-byte 8) stack-effect)) - (setf (instruction-stack instruction) (1- stack-effect)))) - ;; Index of local variable used to hold the current thread. (defvar *thread* nil) @@ -1209,10 +1214,8 @@ ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor (define-resolver (182 183 184) (instruction) - (let* ((args (instruction-args instruction)) - (index (pool-method (first args) (second args) (third args)))) - (setf (instruction-args instruction) (u2 index)) - instruction)) + ;; we used to create the pool-method here; that moved to the emit-* layer + instruction) ;; ldc (define-resolver 18 (instruction) From ehuelsmann at common-lisp.net Sat Jul 31 12:52:41 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 31 Jul 2010 08:52:41 -0400 Subject: [armedbear-cvs] r12837 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 31 08:52:40 2010 New Revision: 12837 Log: Introduce EMIT-GETSTATIC and EMIT-PUTSTATIC in order to be able to make the getstatic and putstatic resolvers side-effect free in terms of the class file being generated. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Jul 31 08:52:40 2010 @@ -342,17 +342,17 @@ (defknown emit-push-nil () t) (declaim (inline emit-push-nil)) (defun emit-push-nil () - (emit 'getstatic +lisp-class+ "NIL" +lisp-object+)) + (emit-getstatic +lisp-class+ "NIL" +lisp-object+)) (defknown emit-push-nil-symbol () t) (declaim (inline emit-push-nil-symbol)) (defun emit-push-nil-symbol () - (emit 'getstatic +lisp-nil-class+ "NIL" +lisp-symbol+)) + (emit-getstatic +lisp-nil-class+ "NIL" +lisp-symbol+)) (defknown emit-push-t () t) (declaim (inline emit-push-t)) (defun emit-push-t () - (emit 'getstatic +lisp-class+ "T" +lisp-symbol+)) + (emit-getstatic +lisp-class+ "T" +lisp-symbol+)) (defknown emit-push-false (t) t) (defun emit-push-false (representation) @@ -570,6 +570,17 @@ (setf pretty-string (concatenate 'string pretty-string "[]"))) pretty-string)) +(declaim (inline emit-getstatic emit-putstatic)) +(defknown emit-getstatic (t t t) t) +(defun emit-getstatic (class-name field-name type) + (let ((index (pool-field class-name field-name type))) + (apply #'%emit 'getstatic (u2 index)))) + +(defknown emit-putstatic (t t t) t) +(defun emit-putstatic (class-name field-name type) + (let ((index (pool-field class-name field-name type))) + (apply #'%emit 'putstatic (u2 index)))) + (defvar type-representations '((:int fixnum) (:long (integer #.most-negative-java-long #.most-positive-java-long)) @@ -772,7 +783,7 @@ (emit 'instanceof instanceof-class) (emit 'ifne LABEL1) (emit-load-local-variable variable) - (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name + (emit-getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) (emit-invokestatic +lisp-class+ "type_error" (lisp-object-arg-types 2) +lisp-object+) @@ -832,7 +843,7 @@ (defun maybe-generate-interrupt-check () (unless (> *speed* *safety*) (let ((label1 (gensym))) - (emit 'getstatic +lisp-class+ "interrupted" "Z") + (emit-getstatic +lisp-class+ "interrupted" "Z") (emit 'ifeq label1) (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil) (label label1)))) @@ -1196,9 +1207,8 @@ ;; getstatic, putstatic (define-resolver (178 179) (instruction) - (let* ((args (instruction-args instruction)) - (index (pool-field (first args) (second args) (third args)))) - (inst (instruction-opcode instruction) (u2 index)))) + ;; we used to create the pool-field here; that moved to the emit-* layer + instruction) ;; bipush, sipush (define-resolver (16 17) (instruction) @@ -1834,7 +1844,7 @@ (if (null (third param)) ;; supplied-p (emit-push-nil) (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I") + (emit-getstatic +lisp-closure-class+ "OPTIONAL" "I") (emit-invokespecial-init +lisp-closure-parameter-class+ (list +lisp-symbol+ +lisp-object+ +lisp-object+ "I"))) @@ -2032,7 +2042,7 @@ (defun serialize-integer (n) "Generates code to restore a serialized integer." (cond((<= 0 n 255) - (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) + (emit-getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) (emit-push-constant-int n) (emit 'aaload)) ((<= most-negative-fixnum n most-positive-fixnum) @@ -2101,7 +2111,7 @@ (lookup-known-symbol symbol) (cond (name - (emit 'getstatic class name +lisp-symbol+)) + (emit-getstatic class name +lisp-symbol+)) ((null (symbol-package symbol)) (emit-push-constant-int (dump-uninterned-symbol-index symbol)) (emit-invokestatic +lisp-load-class+ "getUninternedSymbol" '("I") @@ -2163,7 +2173,7 @@ (setf similarity-fn #'eq)) (let ((existing (assoc object *externalized-objects* :test similarity-fn))) (when existing - (emit 'getstatic *this-class* (cdr existing) field-type) + (emit-getstatic *this-class* (cdr existing) field-type) (when cast (emit 'checkcast cast)) (return-from emit-load-externalized-object field-type))) @@ -2182,18 +2192,18 @@ (list +java-string+) +lisp-object+) (when (string/= field-type +lisp-object+) (emit 'checkcast (subseq field-type 1 (1- (length field-type))))) - (emit 'putstatic *this-class* field-name field-type) + (emit-putstatic *this-class* field-name field-type) (setf *static-code* *code*))) (*declare-inline* (funcall dispatch-fn object) - (emit 'putstatic *this-class* field-name field-type)) + (emit-putstatic *this-class* field-name field-type)) (t (let ((*code* *static-code*)) (funcall dispatch-fn object) - (emit 'putstatic *this-class* field-name field-type) + (emit-putstatic *this-class* field-name field-type) (setf *static-code* *code*)))) - (emit 'getstatic *this-class* field-name field-type) + (emit-getstatic *this-class* field-name field-type) (when cast (emit 'checkcast cast)) field-type))) @@ -2225,9 +2235,9 @@ (let ((*code* (if *declare-inline* *code* *static-code*))) (if (eq class *this-class*) (progn ;; generated by the DECLARE-OBJECT*'s above - (emit 'getstatic class name +lisp-object+) + (emit-getstatic class name +lisp-object+) (emit 'checkcast +lisp-symbol-class+)) - (emit 'getstatic class name +lisp-symbol+)) + (emit-getstatic class name +lisp-symbol+)) (emit-invokevirtual +lisp-symbol-class+ (if setf "getSymbolSetfFunctionOrDie" @@ -2237,7 +2247,7 @@ ;; (AutoloadedFunctionProxy) by allowing it to resolve itself (emit-invokevirtual +lisp-object-class+ "resolve" nil +lisp-object+) - (emit 'putstatic *this-class* f +lisp-object+) + (emit-putstatic *this-class* f +lisp-object+) (if *declare-inline* (setf saved-code *code*) (setf *static-code* *code*)) @@ -2273,7 +2283,7 @@ ; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" ; (list +java-string+) +lisp-object+) - (emit 'putstatic *this-class* g +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+) (setf *static-code* *code*) (setf (gethash local-function ht) g)))) @@ -2298,7 +2308,7 @@ (emit 'ldc (pool-string s)) (emit-invokestatic +lisp-class+ "readObjectFromString" (list +java-string+) +lisp-object+) - (emit 'putstatic *this-class* g +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+) (if *declare-inline* (setf saved-code *code*) (setf *static-code* *code*))) @@ -2320,7 +2330,7 @@ (list +java-string+) +lisp-object+) (emit-invokestatic +lisp-class+ "loadTimeValue" (lisp-object-arg-types 1) +lisp-object+) - (emit 'putstatic *this-class* g +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+) (if *declare-inline* (setf saved-code *code*) (setf *static-code* *code*))) @@ -2345,7 +2355,7 @@ (list +java-string+) +lisp-object+) (when (and obj-class (string/= obj-class +lisp-object-class+)) (emit 'checkcast obj-class)) - (emit 'putstatic *this-class* g obj-ref) + (emit-putstatic *this-class* g obj-ref) (setf *static-code* *code*) g))) @@ -3068,7 +3078,7 @@ (declare-local-function local-function) (declare-object (local-function-function local-function))))) - (emit 'getstatic *this-class* g +lisp-object+) + (emit-getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* (emit 'checkcast +lisp-compiled-closure-class+) @@ -4789,7 +4799,7 @@ (defun p2-load-time-value (form target representation) (cond (*file-compilation* - (emit 'getstatic *this-class* + (emit-getstatic *this-class* (declare-load-time-value (second form)) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -4920,7 +4930,7 @@ (defun emit-make-compiled-closure-for-labels (local-function compiland declaration) - (emit 'getstatic *this-class* declaration +lisp-object+) + (emit-getstatic *this-class* declaration +lisp-object+) (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) (dformat t "(compiland-closure-register parent) = ~S~%" @@ -5005,7 +5015,7 @@ (let ((class-file (compiland-class-file compiland))) (with-open-class-file (f class-file) (compile-and-write-to-stream class-file compiland f)) - (emit 'getstatic *this-class* + (emit-getstatic *this-class* (declare-local-function (make-local-function :class-file class-file)) +lisp-object+))) @@ -5051,7 +5061,7 @@ (declare-local-function local-function) (declare-object (local-function-function local-function))))) - (emit 'getstatic *this-class* g +lisp-object+) + (emit-getstatic *this-class* g +lisp-object+) ; Stack: template-function (when (compiland-closure-register *current-compiland*) @@ -5062,7 +5072,7 @@ +lisp-object+))))) (emit-move-from-stack target)) ((inline-ok name) - (emit 'getstatic *this-class* + (emit-getstatic *this-class* (declare-function name) +lisp-object+) (emit-move-from-stack target)) (t @@ -5092,11 +5102,11 @@ (declare-local-function local-function) (declare-object (local-function-function local-function))))) - (emit 'getstatic *this-class* + (emit-getstatic *this-class* g +lisp-object+))))) ; Stack: template-function ((and (member name *functions-defined-in-current-file* :test #'equal) (not (notinline-p name))) - (emit 'getstatic *this-class* + (emit-getstatic *this-class* (declare-setf-function name) +lisp-object+) (emit-move-from-stack target)) ((and (null *file-compilation*) @@ -7468,7 +7478,7 @@ (emit 'dup) (emit 'instanceof instanceof-class) (emit 'ifne LABEL1) - (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) + (emit-getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) (emit-invokestatic +lisp-class+ "type_error" (lisp-object-arg-types 2) +lisp-object+) (label LABEL1)) From ehuelsmann at common-lisp.net Sat Jul 31 18:24:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 31 Jul 2010 14:24:35 -0400 Subject: [armedbear-cvs] r12838 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 31 14:24:34 2010 New Revision: 12838 Log: Backport r12834-12836, resolving merge conflicts along the way. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Jul 31 14:24:34 2010 @@ -442,22 +442,6 @@ (defparameter *descriptors* (make-hash-table :test #'equal)) -;; Just an experiment... -(defmacro defsubst (name lambda-list &rest body) - (let* ((block-name (fdefinition-block-name name)) - (expansion (generate-inline-expansion block-name lambda-list body))) - `(progn - (%defun ',name (lambda ,lambda-list (block ,block-name , at body))) - (precompile ',name) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (inline-expansion ',name) ',expansion)) - ',name))) - -#+nil -(defmacro defsubst (&rest args) - `(defun , at args)) - - (declaim (ftype (function (t t) cons) get-descriptor-info)) (defun get-descriptor-info (arg-types return-type) (let* ((arg-types (mapcar #'!class-ref arg-types)) @@ -469,7 +453,8 @@ (or descriptor-info (setf (gethash key ht) (make-descriptor-info arg-types return-type))))) -(defsubst get-descriptor (arg-types return-type) +(declaim (inline get-descriptor)) +(defun get-descriptor (arg-types return-type) (car (get-descriptor-info arg-types return-type))) (declaim (ftype (function * t) emit-invokestatic)) @@ -478,9 +463,54 @@ (descriptor (car info)) (stack-effect (cdr info)) (class-name (!class-name class-name)) - (instruction (emit 'invokestatic class-name method-name descriptor))) + (index (pool-method class-name method-name descriptor)) + (instruction (apply #'%emit 'invokestatic (u2 index)))) (setf (instruction-stack instruction) stack-effect))) + + +(declaim (ftype (function t string) pretty-java-class)) +(defun pretty-java-class (class) + (cond ((equal (!class-name class) (!class-name +lisp-object+)) + "LispObject") + ((equal class +lisp-symbol+) + "Symbol") + ((equal class +lisp-thread+) + "LispThread") + (t + class))) + +(defknown emit-invokevirtual (t t t t) t) +(defun emit-invokevirtual (class-name method-name arg-types return-type) + (let* ((info (get-descriptor-info arg-types return-type)) + (descriptor (car info)) + (stack-effect (cdr info)) + (class-name (!class-name class-name)) + (index (pool-method class-name method-name descriptor)) + (instruction (apply #'%emit 'invokevirtual (u2 index)))) + (declare (type (signed-byte 8) stack-effect)) + (let ((explain *explain*)) + (when (and explain (memq :java-calls explain)) + (unless (string= method-name "execute") + (format t "; call to ~A ~A.~A(~{~A~^,~})~%" + (pretty-java-type return-type) + (pretty-java-class class-name) + method-name + (mapcar 'pretty-java-type arg-types))))) + (setf (instruction-stack instruction) (1- stack-effect)))) + +(defknown emit-invokespecial-init (string list) t) +(defun emit-invokespecial-init (class-name arg-types) + (let* ((info (get-descriptor-info arg-types nil)) + (descriptor (car info)) + (stack-effect (cdr info)) + (class-name (!class-name class-name)) + (index (pool-method class-name "" descriptor)) + (instruction (apply #'%emit 'invokespecial (u2 index)))) + (declare (type (signed-byte 8) stack-effect)) + (setf (instruction-stack instruction) (1- stack-effect)))) + + (defknown pretty-java-type (t) string) (defun pretty-java-type (type) (let ((arrayp nil) @@ -644,46 +674,6 @@ (return-from common-representation result))))) - -(declaim (ftype (function t string) pretty-java-class)) -(defun pretty-java-class (class) - (cond ((equal (!class-name class) (!class-name +lisp-object+)) - "LispObject") - ((equal class +lisp-symbol+) - "Symbol") - ((equal class +lisp-thread+) - "LispThread") - (t - class))) - -(defknown emit-invokevirtual (t t t t) t) -(defun emit-invokevirtual (class-name method-name arg-types return-type) - (let* ((info (get-descriptor-info arg-types return-type)) - (descriptor (car info)) - (stack-effect (cdr info)) - (class-name (!class-name class-name)) - (instruction (emit 'invokevirtual class-name method-name descriptor))) - (declare (type (signed-byte 8) stack-effect)) - (let ((explain *explain*)) - (when (and explain (memq :java-calls explain)) - (unless (string= method-name "execute") - (format t "; call to ~A ~A.~A(~{~A~^,~})~%" - (pretty-java-type return-type) - (pretty-java-class class-name) - method-name - (mapcar 'pretty-java-type arg-types))))) - (setf (instruction-stack instruction) (1- stack-effect)))) - -(defknown emit-invokespecial-init (string list) t) -(defun emit-invokespecial-init (class-name arg-types) - (let* ((info (get-descriptor-info arg-types nil)) - (descriptor (car info)) - (stack-effect (cdr info)) - (class-name (!class-name class-name)) - (instruction (emit 'invokespecial class-name "" descriptor))) - (declare (type (signed-byte 8) stack-effect)) - (setf (instruction-stack instruction) (1- stack-effect)))) - ;; Index of local variable used to hold the current thread. (defvar *thread* nil) @@ -1196,11 +1186,8 @@ ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor (define-resolver (182 183 184) (instruction) - (let* ((args (instruction-args instruction)) - (index (pool-method (!class-name (first args)) - (second args) (third args)))) - (setf (instruction-args instruction) (u2 index)) - instruction)) + ;; we used to create the pool-method here; that moved to the emit-* layer + instruction) ;; ldc (define-resolver 18 (instruction) From ehuelsmann at common-lisp.net Sat Jul 31 19:21:21 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 31 Jul 2010 15:21:21 -0400 Subject: [armedbear-cvs] r12839 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 31 15:21:20 2010 New Revision: 12839 Log: Backport r12837, resolving merge conflicts along the way. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Jul 31 15:21:20 2010 @@ -308,17 +308,17 @@ (defknown emit-push-nil () t) (declaim (inline emit-push-nil)) (defun emit-push-nil () - (emit 'getstatic +lisp+ "NIL" +lisp-object+)) + (emit-getstatic +lisp+ "NIL" +lisp-object+)) (defknown emit-push-nil-symbol () t) (declaim (inline emit-push-nil-symbol)) (defun emit-push-nil-symbol () - (emit 'getstatic +lisp-nil+ "NIL" +lisp-symbol+)) + (emit-getstatic +lisp-nil+ "NIL" +lisp-symbol+)) (defknown emit-push-t () t) (declaim (inline emit-push-t)) (defun emit-push-t () - (emit 'getstatic +lisp+ "T" +lisp-symbol+)) + (emit-getstatic +lisp+ "T" +lisp-symbol+)) (defknown emit-push-false (t) t) (defun emit-push-false (representation) @@ -541,6 +541,19 @@ (setf pretty-string (concatenate 'string pretty-string "[]"))) pretty-string)) +(declaim (inline emit-getstatic emit-putstatic)) +(defknown emit-getstatic (t t t) t) +(defun emit-getstatic (class-name field-name type) + (let ((index (pool-field (!class-name class-name) + field-name (!class-ref type)))) + (apply #'%emit 'getstatic (u2 index)))) + +(defknown emit-putstatic (t t t) t) +(defun emit-putstatic (class-name field-name type) + (let ((index (pool-field (!class-name class-name) + field-name (!class-ref type)))) + (apply #'%emit 'putstatic (u2 index)))) + (defvar type-representations '((:int fixnum) (:long (integer #.most-negative-java-long #.most-positive-java-long)) @@ -743,7 +756,7 @@ (emit 'instanceof instanceof-class) (emit 'ifne LABEL1) (emit-load-local-variable variable) - (emit 'getstatic +lisp-symbol+ expected-type-java-symbol-name + (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+) (emit-invokestatic +lisp+ "type_error" (lisp-object-arg-types 2) +lisp-object+) @@ -803,7 +816,7 @@ (defun maybe-generate-interrupt-check () (unless (> *speed* *safety*) (let ((label1 (gensym))) - (emit 'getstatic +lisp+ "interrupted" "Z") + (emit-getstatic +lisp+ "interrupted" "Z") (emit 'ifeq label1) (emit-invokestatic +lisp+ "handleInterrupt" nil nil) (label label1)))) @@ -1167,10 +1180,8 @@ ;; getstatic, putstatic (define-resolver (178 179) (instruction) - (let* ((args (instruction-args instruction)) - (index (pool-field (!class-name (first args)) - (second args) (!class-ref (third args))))) - (inst (instruction-opcode instruction) (u2 index)))) + ;; we used to create the pool-field here; that moved to the emit-* layer + instruction) ;; bipush, sipush (define-resolver (16 17) (instruction) @@ -1810,7 +1821,7 @@ (if (null (third param)) ;; supplied-p (emit-push-nil) (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit 'getstatic +lisp-closure+ "OPTIONAL" "I") + (emit-getstatic +lisp-closure+ "OPTIONAL" "I") (emit-invokespecial-init +lisp-closure-parameter+ (list +lisp-symbol+ +lisp-object+ +lisp-object+ "I"))) @@ -2008,7 +2019,7 @@ (defun serialize-integer (n) "Generates code to restore a serialized integer." (cond((<= 0 n 255) - (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) + (emit-getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) (emit-push-constant-int n) (emit 'aaload)) ((<= most-negative-fixnum n most-positive-fixnum) @@ -2077,7 +2088,7 @@ (lookup-known-symbol symbol) (cond (name - (emit 'getstatic class name +lisp-symbol+)) + (emit-getstatic class name +lisp-symbol+)) ((null (symbol-package symbol)) (emit-push-constant-int (dump-uninterned-symbol-index symbol)) (emit-invokestatic +lisp-load+ "getUninternedSymbol" '("I") @@ -2139,7 +2150,7 @@ (setf similarity-fn #'eq)) (let ((existing (assoc object *externalized-objects* :test similarity-fn))) (when existing - (emit 'getstatic *this-class* (cdr existing) field-type) + (emit-getstatic *this-class* (cdr existing) field-type) (when cast (emit 'checkcast cast)) (return-from emit-load-externalized-object field-type))) @@ -2158,18 +2169,18 @@ (list +java-string+) +lisp-object+) (when (not (eq field-type +lisp-object+)) (emit 'checkcast field-type)) - (emit 'putstatic *this-class* field-name field-type) + (emit-putstatic *this-class* field-name field-type) (setf *static-code* *code*))) (*declare-inline* (funcall dispatch-fn object) - (emit 'putstatic *this-class* field-name field-type)) + (emit-putstatic *this-class* field-name field-type)) (t (let ((*code* *static-code*)) (funcall dispatch-fn object) - (emit 'putstatic *this-class* field-name field-type) + (emit-putstatic *this-class* field-name field-type) (setf *static-code* *code*)))) - (emit 'getstatic *this-class* field-name field-type) + (emit-getstatic *this-class* field-name field-type) (when cast (emit 'checkcast cast)) field-type))) @@ -2201,9 +2212,9 @@ (let ((*code* (if *declare-inline* *code* *static-code*))) (if (eq class *this-class*) (progn ;; generated by the DECLARE-OBJECT*'s above - (emit 'getstatic class name +lisp-object+) + (emit-getstatic class name +lisp-object+) (emit 'checkcast +lisp-symbol+)) - (emit 'getstatic class name +lisp-symbol+)) + (emit-getstatic class name +lisp-symbol+)) (emit-invokevirtual +lisp-symbol+ (if setf "getSymbolSetfFunctionOrDie" @@ -2213,7 +2224,7 @@ ;; (AutoloadedFunctionProxy) by allowing it to resolve itself (emit-invokevirtual +lisp-object+ "resolve" nil +lisp-object+) - (emit 'putstatic *this-class* f +lisp-object+) + (emit-putstatic *this-class* f +lisp-object+) (if *declare-inline* (setf saved-code *code*) (setf *static-code* *code*)) @@ -2240,7 +2251,7 @@ (emit 'new class-name) (emit 'dup) (emit-invokespecial-init class-name '()) - (emit 'putstatic *this-class* g +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+) (setf *static-code* *code*) (setf (gethash local-function ht) g)))) @@ -2265,7 +2276,7 @@ (emit 'ldc (pool-string s)) (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+) - (emit 'putstatic *this-class* g +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+) (if *declare-inline* (setf saved-code *code*) (setf *static-code* *code*))) @@ -2287,7 +2298,7 @@ (list +java-string+) +lisp-object+) (emit-invokestatic +lisp+ "loadTimeValue" (lisp-object-arg-types 1) +lisp-object+) - (emit 'putstatic *this-class* g +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+) (if *declare-inline* (setf saved-code *code*) (setf *static-code* *code*))) @@ -2309,7 +2320,7 @@ (emit 'ldc (pool-string g)) (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) - (emit 'putstatic *this-class* g +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+) (setf *static-code* *code*) g))) @@ -3032,7 +3043,7 @@ (declare-local-function local-function) (declare-object (local-function-function local-function))))) - (emit 'getstatic *this-class* g +lisp-object+) + (emit-getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* (emit 'checkcast +lisp-compiled-closure+) @@ -4753,7 +4764,7 @@ (defun p2-load-time-value (form target representation) (cond (*file-compilation* - (emit 'getstatic *this-class* + (emit-getstatic *this-class* (declare-load-time-value (second form)) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -4884,7 +4895,7 @@ (defun emit-make-compiled-closure-for-labels (local-function compiland declaration) - (emit 'getstatic *this-class* declaration +lisp-object+) + (emit-getstatic *this-class* declaration +lisp-object+) (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) (dformat t "(compiland-closure-register parent) = ~S~%" @@ -4969,7 +4980,7 @@ (let ((class-file (compiland-class-file compiland))) (with-open-class-file (f class-file) (compile-and-write-to-stream class-file compiland f)) - (emit 'getstatic *this-class* + (emit-getstatic *this-class* (declare-local-function (make-local-function :class-file class-file)) +lisp-object+))) @@ -5015,7 +5026,7 @@ (declare-local-function local-function) (declare-object (local-function-function local-function))))) - (emit 'getstatic *this-class* g +lisp-object+) + (emit-getstatic *this-class* g +lisp-object+) ; Stack: template-function (when (compiland-closure-register *current-compiland*) @@ -5026,7 +5037,7 @@ +lisp-object+))))) (emit-move-from-stack target)) ((inline-ok name) - (emit 'getstatic *this-class* + (emit-getstatic *this-class* (declare-function name) +lisp-object+) (emit-move-from-stack target)) (t @@ -5056,11 +5067,11 @@ (declare-local-function local-function) (declare-object (local-function-function local-function))))) - (emit 'getstatic *this-class* + (emit-getstatic *this-class* g +lisp-object+))))) ; Stack: template-function ((and (member name *functions-defined-in-current-file* :test #'equal) (not (notinline-p name))) - (emit 'getstatic *this-class* + (emit-getstatic *this-class* (declare-setf-function name) +lisp-object+) (emit-move-from-stack target)) ((and (null *file-compilation*) @@ -7432,7 +7443,7 @@ (emit 'dup) (emit 'instanceof instanceof-class) (emit 'ifne LABEL1) - (emit 'getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+) + (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+) (emit-invokestatic +lisp+ "type_error" (lisp-object-arg-types 2) +lisp-object+) (label LABEL1)) From ehuelsmann at common-lisp.net Sat Jul 31 21:33:25 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 31 Jul 2010 17:33:25 -0400 Subject: [armedbear-cvs] r12840 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jul 31 17:33:24 2010 New Revision: 12840 Log: Introduce "dual mode" operation for emit-invoke* and emit-*static, in order to allow test-writing. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Jul 31 17:33:24 2010 @@ -463,7 +463,10 @@ (descriptor (car info)) (stack-effect (cdr info)) (class-name (!class-name class-name)) - (index (pool-method class-name method-name descriptor)) + (index (if (null *current-code-attribute*) + (pool-method class-name method-name descriptor) + (pool-add-method-ref *pool* class-name + method-name descriptor))) (instruction (apply #'%emit 'invokestatic (u2 index)))) (setf (instruction-stack instruction) stack-effect))) @@ -486,7 +489,10 @@ (descriptor (car info)) (stack-effect (cdr info)) (class-name (!class-name class-name)) - (index (pool-method class-name method-name descriptor)) + (index (if (null *current-code-attribute*) + (pool-method class-name method-name descriptor) + (pool-add-method-ref *pool* class-name + method-name descriptor))) (instruction (apply #'%emit 'invokevirtual (u2 index)))) (declare (type (signed-byte 8) stack-effect)) (let ((explain *explain*)) @@ -505,7 +511,10 @@ (descriptor (car info)) (stack-effect (cdr info)) (class-name (!class-name class-name)) - (index (pool-method class-name "" descriptor)) + (index (if (null *current-code-attribute*) + (pool-method class-name "" descriptor) + (pool-add-method-ref *pool* class-name + "" descriptor))) (instruction (apply #'%emit 'invokespecial (u2 index)))) (declare (type (signed-byte 8) stack-effect)) (setf (instruction-stack instruction) (1- stack-effect)))) @@ -544,14 +553,18 @@ (declaim (inline emit-getstatic emit-putstatic)) (defknown emit-getstatic (t t t) t) (defun emit-getstatic (class-name field-name type) - (let ((index (pool-field (!class-name class-name) - field-name (!class-ref type)))) + (let ((index (if (null *current-code-attribute*) + (pool-field (!class-name class-name) + field-name (!class-ref type)) + (pool-add-field-ref *pool* class-name field-name type)))) (apply #'%emit 'getstatic (u2 index)))) (defknown emit-putstatic (t t t) t) (defun emit-putstatic (class-name field-name type) - (let ((index (pool-field (!class-name class-name) - field-name (!class-ref type)))) + (let ((index (if (null *current-code-attribute*) + (pool-field (!class-name class-name) + field-name (!class-ref type)) + (pool-add-field-ref *pool* class-name field-name type)))) (apply #'%emit 'putstatic (u2 index)))) (defvar type-representations '((:int fixnum) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sat Jul 31 17:33:24 2010 @@ -875,7 +875,7 @@ ) -(defvar *current-code-attribute*) +(defvar *current-code-attribute* nil) (defun save-code-specials (code) (setf (code-code code) *code* @@ -889,7 +889,7 @@ *registers-allocated* (code-max-locals code) *register* (code-current-local code))) -(defmacro with-code-to-method ((method &key safe-nesting) &body body) +(defmacro with-code-to-method ((class-file method &key safe-nesting) &body body) (let ((m (gensym)) (c (gensym))) `(progn @@ -898,6 +898,7 @@ (save-code-specials *current-code-attribute*)))) (let* ((,m ,method) (,c (method-ensure-code method)) + (*pool* (class-file-constants ,class-file)) (*code* (code-code ,c)) (*registers-allocated* (code-max-locals ,c)) (*register* (code-current-local ,c))