From mevenson at common-lisp.net Sat Jun 4 20:24:33 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:24:33 -0700 Subject: [armedbear-cvs] r13276 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue May 17 03:51:08 2011 New Revision: 13276 Log: Untabify. Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java Sat May 7 16:31:35 2011 (r13275) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Tue May 17 03:51:08 2011 (r13276) @@ -46,8 +46,8 @@ public JavaObject(Object obj) { this.obj = obj; - this.intendedClass = - obj != null ? Java.maybeBoxClass(obj.getClass()) : null; + this.intendedClass = + obj != null ? Java.maybeBoxClass(obj.getClass()) : null; } public static final Symbol JAVA_CLASS_JCLASS = PACKAGE_JAVA.intern("JAVA-CLASS-JCLASS"); @@ -62,17 +62,17 @@ * intended class. */ public JavaObject(Object obj, Class intendedClass) { - if(obj != null && intendedClass == null) { - intendedClass = obj.getClass(); - } - if(intendedClass != null) { - intendedClass = Java.maybeBoxClass(intendedClass); - if(!intendedClass.isInstance(obj)) { - throw new ClassCastException(obj + " can not be cast to " + intendedClass); - } - } - this.obj = obj; - this.intendedClass = intendedClass; + if(obj != null && intendedClass == null) { + intendedClass = obj.getClass(); + } + if(intendedClass != null) { + intendedClass = Java.maybeBoxClass(intendedClass); + if(!intendedClass.isInstance(obj)) { + throw new ClassCastException(obj + " can not be cast to " + intendedClass); + } + } + this.obj = obj; + this.intendedClass = intendedClass; } @Override @@ -87,7 +87,7 @@ if(obj == null) { return BuiltInClass.JAVA_OBJECT; } else { - return ENSURE_JAVA_CLASS.execute(new JavaObject(obj.getClass())); + return ENSURE_JAVA_CLASS.execute(new JavaObject(obj.getClass())); } } @@ -97,28 +97,28 @@ return T; if (type == BuiltInClass.JAVA_OBJECT) return T; - 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(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; - } - } + 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(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); } @@ -177,7 +177,7 @@ * @return a LispObject representing or encapsulating obj */ public final static LispObject getInstance(Object obj, boolean translated) { - return getInstance(obj, translated, obj != null ? obj.getClass() : null); + return getInstance(obj, translated, obj != null ? obj.getClass() : null); } @@ -262,14 +262,14 @@ @Override public Object javaInstance(Class c) { - if(obj == null) { - if(c.isPrimitive()) { - throw new NullPointerException("Cannot assign null to " + c); - } - return obj; - } else { - c = Java.maybeBoxClass(c); - if (c.isAssignableFrom(intendedClass) || c.isInstance(obj)) { + if(obj == null) { + if(c.isPrimitive()) { + throw new NullPointerException("Cannot assign null to " + c); + } + return obj; + } else { + c = Java.maybeBoxClass(c); + if (c.isAssignableFrom(intendedClass) || c.isInstance(obj)) { // XXX In the case that c.isInstance(obj) should we then // "fix" the intendedClass field with the (presumably) // narrower type of 'obj'? @@ -279,11 +279,11 @@ // there's something "narrower" and b) I'm not sure how // primitive types relate to their boxed // representations. - return obj; - } else { - return error(new TypeError(intendedClass.getName() + " is not assignable to " + c.getName())); - } - } + return obj; + } else { + return error(new TypeError(intendedClass.getName() + " is not assignable to " + c.getName())); + } + } } /** Returns the encapsulated Java object for @@ -297,7 +297,7 @@ } public Class getIntendedClass() { - return intendedClass; + return intendedClass; } public static final Object getObject(LispObject o) @@ -336,79 +336,79 @@ { if (obj instanceof ControlTransfer) return obj.toString(); - final String s; - if(obj != null) { - Class c = obj.getClass(); - StringBuilder sb - = new StringBuilder(c.isArray() ? "jarray" : c.getName()); - sb.append(' '); - String ts = obj.toString(); - if(ts.length() > 32) { //random value, should be chosen sensibly - sb.append(ts.substring(0, 32) + "..."); - } else { - sb.append(ts); - } - s = sb.toString(); - } else { - s = "null"; - } + final String s; + if(obj != null) { + Class c = obj.getClass(); + StringBuilder sb + = new StringBuilder(c.isArray() ? "jarray" : c.getName()); + sb.append(' '); + String ts = obj.toString(); + if(ts.length() > 32) { //random value, should be chosen sensibly + sb.append(ts.substring(0, 32) + "..."); + } else { + sb.append(ts); + } + s = sb.toString(); + } else { + s = "null"; + } return unreadableString(s); } @Override public LispObject getDescription() { - return new SimpleString(describeJavaObject(this)); + return new SimpleString(describeJavaObject(this)); } @Override public LispObject getParts() { - if(obj != null) { - LispObject parts = NIL; + if(obj != null) { + LispObject parts = NIL; parts = parts.push(new Cons("Java class", new JavaObject(obj.getClass()))); if (intendedClass != null) { parts = parts.push(new Cons("intendedClass", new SimpleString(intendedClass.getCanonicalName()))); } - if (obj.getClass().isArray()) { - int length = Array.getLength(obj); - for (int i = 0; i < length; i++) { - parts = parts + if (obj.getClass().isArray()) { + int length = Array.getLength(obj); + for (int i = 0; i < length; i++) { + parts = parts .push(new Cons(new SimpleString(i), JavaObject.getInstance(Array.get(obj, i)))); - } - } else { - parts = Symbol.NCONC.execute(parts, getInspectedFields()); - } - return parts.nreverse(); - } else { - return NIL; - } + } + } else { + parts = Symbol.NCONC.execute(parts, getInspectedFields()); + } + return parts.nreverse(); + } else { + return NIL; + } } private LispObject getInspectedFields() - { - final LispObject[] acc = new LispObject[] { NIL }; - doClassHierarchy(obj.getClass(), new Function() { - @Override - public LispObject execute(LispObject arg) - { - //No possibility of type error - we're mapping this function - //over a list of classes - Class c = (Class) arg.javaInstance(); - for(Field f : c.getDeclaredFields()) { - LispObject value = NIL; - try { - if(!f.isAccessible()) { - f.setAccessible(true); - } - value = JavaObject.getInstance(f.get(obj)); - } catch(Exception e) {} - acc[0] = acc[0].push(new Cons(f.getName(), value)); - } - return acc[0]; - } - }); - return acc[0].nreverse(); + { + final LispObject[] acc = new LispObject[] { NIL }; + doClassHierarchy(obj.getClass(), new Function() { + @Override + public LispObject execute(LispObject arg) + { + //No possibility of type error - we're mapping this function + //over a list of classes + Class c = (Class) arg.javaInstance(); + for(Field f : c.getDeclaredFields()) { + LispObject value = NIL; + try { + if(!f.isAccessible()) { + f.setAccessible(true); + } + value = JavaObject.getInstance(f.get(obj)); + } catch(Exception e) {} + acc[0] = acc[0].push(new Cons(f.getName(), value)); + } + return acc[0]; + } + }); + return acc[0].nreverse(); } /** @@ -416,30 +416,30 @@ * Java class hierarchy which contains every class in . */ private static void doClassHierarchy(Collection> classes, - LispObject callback, - Set> visited) - { - Collection> newClasses = new LinkedList>(); - for(Class clss : classes) { - if(clss == null) { - continue; - } - if(!visited.contains(clss)) { - callback.execute(JavaObject.getInstance(clss, true)); - visited.add(clss); - } - if(!visited.contains(clss.getSuperclass())) { - newClasses.add(clss.getSuperclass()); - } - for(Class iface : clss.getInterfaces()) { - if (!visited.contains(iface)) { - newClasses.add(iface); - } - } - } - if(!newClasses.isEmpty()) { - doClassHierarchy(newClasses, callback, visited); - } + LispObject callback, + Set> visited) + { + Collection> newClasses = new LinkedList>(); + for(Class clss : classes) { + if(clss == null) { + continue; + } + if(!visited.contains(clss)) { + callback.execute(JavaObject.getInstance(clss, true)); + visited.add(clss); + } + if(!visited.contains(clss.getSuperclass())) { + newClasses.add(clss.getSuperclass()); + } + for(Class iface : clss.getInterfaces()) { + if (!visited.contains(iface)) { + newClasses.add(iface); + } + } + } + if(!newClasses.isEmpty()) { + doClassHierarchy(newClasses, callback, visited); + } } /** @@ -447,87 +447,87 @@ * interfaces. */ public static void doClassHierarchy(Class clss, LispObject callback) - { - if (clss != null) { - Set> visited = new HashSet>(); - Collection> classes = new ArrayList>(1); - classes.add(clss); - doClassHierarchy(classes, callback, visited); - } + { + if (clss != null) { + Set> visited = new HashSet>(); + Collection> classes = new ArrayList>(1); + classes.add(clss); + doClassHierarchy(classes, callback, visited); + } } public static LispObject mapcarClassHierarchy(Class clss, - final LispObject fn) + final LispObject fn) { - final LispObject[] acc = new LispObject[] { NIL }; - doClassHierarchy(clss, new Function() { - @Override - public LispObject execute(LispObject arg) - { - acc[0] = acc[0].push(fn.execute(arg)); - return acc[0]; - } - }); - return acc[0].nreverse(); + final LispObject[] acc = new LispObject[] { NIL }; + doClassHierarchy(clss, new Function() { + @Override + public LispObject execute(LispObject arg) + { + acc[0] = acc[0].push(fn.execute(arg)); + return acc[0]; + } + }); + return acc[0].nreverse(); } public static String describeJavaObject(final JavaObject javaObject) - { - final Object obj = javaObject.getObject(); - final StringBuilder sb = - new StringBuilder(javaObject.writeToString()); - sb.append(" is an object of type "); - sb.append(Symbol.JAVA_OBJECT.writeToString()); - sb.append("."); - sb.append(System.getProperty("line.separator")); - sb.append("The wrapped Java object is "); - if (obj == null) { - sb.append("null."); - } else { - sb.append("an "); - final Class c = obj.getClass(); - String className = c.getName(); - if (c.isArray()) { - sb.append("array of "); - if (className.startsWith("[L") && className.endsWith(";")) { - className = className.substring(1, className.length() - 1); - sb.append(className); - sb.append(" objects"); - } else if (className.startsWith("[") && className.length() > 1) { - char descriptor = className.charAt(1); - final String type; - switch (descriptor) { - case 'B': type = "bytes"; break; - case 'C': type = "chars"; break; - case 'D': type = "doubles"; break; - case 'F': type = "floats"; break; - case 'I': type = "ints"; break; - case 'J': type = "longs"; break; - case 'S': type = "shorts"; break; - case 'Z': type = "booleans"; break; - default: - type = "unknown type"; - } - sb.append(type); - } - sb.append(" with "); - final int length = java.lang.reflect.Array.getLength(obj); - sb.append(length); - sb.append(" element"); - if (length != 1) - sb.append('s'); - sb.append('.'); - } else { - sb.append("instance of "); - sb.append(className); - sb.append(':'); - sb.append(System.getProperty("line.separator")); - sb.append(" \""); - sb.append(obj.toString()); - sb.append('"'); - } - } - return sb.toString(); + { + final Object obj = javaObject.getObject(); + final StringBuilder sb = + new StringBuilder(javaObject.writeToString()); + sb.append(" is an object of type "); + sb.append(Symbol.JAVA_OBJECT.writeToString()); + sb.append("."); + sb.append(System.getProperty("line.separator")); + sb.append("The wrapped Java object is "); + if (obj == null) { + sb.append("null."); + } else { + sb.append("an "); + final Class c = obj.getClass(); + String className = c.getName(); + if (c.isArray()) { + sb.append("array of "); + if (className.startsWith("[L") && className.endsWith(";")) { + className = className.substring(1, className.length() - 1); + sb.append(className); + sb.append(" objects"); + } else if (className.startsWith("[") && className.length() > 1) { + char descriptor = className.charAt(1); + final String type; + switch (descriptor) { + case 'B': type = "bytes"; break; + case 'C': type = "chars"; break; + case 'D': type = "doubles"; break; + case 'F': type = "floats"; break; + case 'I': type = "ints"; break; + case 'J': type = "longs"; break; + case 'S': type = "shorts"; break; + case 'Z': type = "booleans"; break; + default: + type = "unknown type"; + } + sb.append(type); + } + sb.append(" with "); + final int length = java.lang.reflect.Array.getLength(obj); + sb.append(length); + sb.append(" element"); + if (length != 1) + sb.append('s'); + sb.append('.'); + } else { + sb.append("instance of "); + sb.append(className); + sb.append(':'); + sb.append(System.getProperty("line.separator")); + sb.append(" \""); + sb.append(obj.toString()); + sb.append('"'); + } + } + return sb.toString(); } // ### describe-java-object @@ -555,43 +555,43 @@ private static final Map, LispObject> javaClassMap = new HashMap, LispObject>(); public static LispObject registerJavaClass(Class javaClass, LispObject classMetaObject) { - synchronized (javaClassMap) { - javaClassMap.put(javaClass, classMetaObject); - return classMetaObject; - } + synchronized (javaClassMap) { + javaClassMap.put(javaClass, classMetaObject); + return classMetaObject; + } } public static LispObject findJavaClass(Class javaClass) { - synchronized (javaClassMap) { - LispObject c = javaClassMap.get(javaClass); - if (c != null) { - return c; - } else { - return NIL; - } - } + synchronized (javaClassMap) { + LispObject c = javaClassMap.get(javaClass); + if (c != null) { + return c; + } else { + return NIL; + } + } } private static final Primitive _FIND_JAVA_CLASS = new Primitive("%find-java-class", PACKAGE_JAVA, false, "class-name-or-class") { - public LispObject execute(LispObject arg) { - try { - if(arg instanceof AbstractString) { - return findJavaClass(Class.forName((String) arg.getStringValue())); - } else { - return findJavaClass((Class) arg.javaInstance()); - } - } catch (ClassNotFoundException e) { - return error(new LispError("Cannot find Java class " + arg.getStringValue())); - } - } - - }; + public LispObject execute(LispObject arg) { + try { + if(arg instanceof AbstractString) { + return findJavaClass(Class.forName((String) arg.getStringValue())); + } else { + return findJavaClass((Class) arg.javaInstance()); + } + } catch (ClassNotFoundException e) { + return error(new LispError("Cannot find Java class " + arg.getStringValue())); + } + } + + }; private static final Primitive _REGISTER_JAVA_CLASS = new Primitive("%register-java-class", PACKAGE_JAVA, false, "jclass class-metaobject") { - public LispObject execute(LispObject jclass, LispObject classMetaObject) { - return registerJavaClass((Class) jclass.javaInstance(), classMetaObject); - } - - }; + public LispObject execute(LispObject jclass, LispObject classMetaObject) { + return registerJavaClass((Class) jclass.javaInstance(), classMetaObject); + } + + }; } From mevenson at common-lisp.net Sat Jun 4 20:25:02 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:02 -0700 Subject: [armedbear-cvs] r13277 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue May 17 03:51:30 2011 New Revision: 13277 Log: JAVA:*JAVA-OBJECT-TO-STRING-LENGTH* controls pretty print length. The default of 32 characters is the length beyond which the toString() output from which an otherwise unspecialized JAVA-OBJECT elides its representation. Changed the character sequence indicating elision from "..." to "...." to avoid confusing the user that any of the pretty printer variables are responsible for an elision. Setting this variable to NIL disables truncation of any kind. Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java Tue May 17 03:51:08 2011 (r13276) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Tue May 17 03:51:30 2011 (r13277) @@ -331,6 +331,20 @@ return obj == null ? 0 : (obj.hashCode() & 0x7ffffff); } + public static LispObject JAVA_OBJECT_TO_STRING_LENGTH + = LispInteger.getInstance(32); + + public static final Symbol _JAVA_OBJECT_TO_STRING_LENGTH + = exportSpecial("*JAVA-OBJECT-TO-STRING-LENGTH*", + PACKAGE_JAVA, JAVA_OBJECT_TO_STRING_LENGTH); + + static { + String doc = "Length to truncate toString() PRINT-OBJECT output for an otherwise " + + "unspecialized JAVA-OBJECT. Can be set to NIL to indicate no limit."; + _JAVA_OBJECT_TO_STRING_LENGTH + .setDocumentation(Symbol.VARIABLE, new SimpleString(doc)); + } + @Override public String writeToString() { @@ -343,8 +357,16 @@ = new StringBuilder(c.isArray() ? "jarray" : c.getName()); sb.append(' '); String ts = obj.toString(); - if(ts.length() > 32) { //random value, should be chosen sensibly - sb.append(ts.substring(0, 32) + "..."); + int length = -1; + LispObject stringLength = _JAVA_OBJECT_TO_STRING_LENGTH.symbolValueNoThrow(); + if (stringLength instanceof Fixnum) { + length = Fixnum.getValue(stringLength); + } + if (length < 0) { + sb.append(ts); + }else if (ts.length() > length) { + // use '....' to not confuse user with PPRINT conventions + sb.append(ts.substring(0, length)).append("...."); } else { sb.append(ts); } From mevenson at common-lisp.net Sat Jun 4 20:25:07 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:07 -0700 Subject: [armedbear-cvs] r13278 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue May 17 05:45:44 2011 New Revision: 13278 Log: Add interfaces, superclasses and member classes for JAVA-OBJECT inspector. Make the display of a java Class under SLIME (and via the built-in inspector) a bit more useful by displaying a list of all superclasses in "Superclasses", a list of all implemented interfaces in "Interfaces", and a list of all member classes in "Member classes". In general the information returned by the getParts() inspector contract for java classes could be made quite a bit more useful by adding the output of more methods such as getAnnotations() and getCannonicalName() but for those not using the SLIME inspector there may actually be too much information presented. Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java Tue May 17 03:51:30 2011 (r13277) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Tue May 17 05:45:44 2011 (r13278) @@ -401,6 +401,41 @@ } else { parts = Symbol.NCONC.execute(parts, getInspectedFields()); } + if (obj instanceof java.lang.Class) { + Class o = (java.lang.Class)obj; + try { + Class[] classes = o.getClasses(); + LispObject classesList = NIL; + for (int i = 0; i < classes.length; i++) { + classesList = classesList.push(JavaObject.getInstance(classes[i])); + } + if (!classesList.equals(NIL)) { + parts = parts + .push(new Cons("Member classes", classesList.nreverse())); + } + } catch (SecurityException e) { + Debug.trace(e); + } + Class[] interfaces = o.getInterfaces(); + LispObject interfacesList = NIL; + for (int i = 0; i < interfaces.length; i++) { + interfacesList = interfacesList.push(JavaObject.getInstance(interfaces[i])); + } + if (!interfacesList.equals(NIL)) { + parts = parts + .push(new Cons("Interfaces", interfacesList.nreverse())); + } + LispObject superclassList = NIL; + Class superclass = o.getSuperclass(); + while (superclass != null) { + superclassList = superclassList.push(JavaObject.getInstance(superclass)); + superclass = superclass.getSuperclass(); + } + if (!superclassList.equals(NIL)) { + parts = parts + .push(new Cons("Superclasses", superclassList.nreverse())); + } + } return parts.nreverse(); } else { return NIL; From mevenson at common-lisp.net Sat Jun 4 20:25:13 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:13 -0700 Subject: [armedbear-cvs] r13279 - trunk/abcl Message-ID: Author: mevenson Date: Fri May 20 05:48:16 2011 New Revision: 13279 Log: Fix part of uptodate check for abcl.jar based on Version.java. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Tue May 17 05:45:44 2011 (r13278) +++ trunk/abcl/build.xml Fri May 20 05:48:16 2011 (r13279) @@ -330,15 +330,23 @@ + + + + + depends="abcl.version.src,abcl.stamp.version.1,abcl.stamp.version.2" + unless="abcl.stamp.version.uptodate.p"> ABCL implementation version: ${abcl.implementation.version} ${abcl.implementation.version} - + + + @@ -382,7 +393,7 @@ - + @@ -390,11 +401,11 @@ - + srcFile="${abcl.version.path}"/> From mevenson at common-lisp.net Sat Jun 4 20:25:19 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:19 -0700 Subject: [armedbear-cvs] r13280 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Fri May 20 07:24:30 2011 New Revision: 13280 Log: Import of JSS from . An attempt at unification of JSS with ABCL eventually without the use of additional jars, as the only necessary ingredient of dynamically changing the ABCL classpath at runtme via ADD-TO-CLASSPATH has been present for some time. Added: trunk/abcl/contrib/jss/ trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/jss.asd Added: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jss/invoke.lisp Fri May 20 07:24:30 2011 (r13280) @@ -0,0 +1,853 @@ +;; invoke.lisp v1.0 +;; +;; Copyright (C) 2005 Alan Ruttenberg +;; +;; Since most of this code is derivative of the Jscheme System, it is +;; licensed under the same terms, namely: + +;; This software is provided 'as-is', without any express or +;; implied warranty. + +;; In no event will the author be held liable for any damages +;; arising from the use of this software. + +;; Permission is granted to anyone to use this software for any +;; purpose, including commercial applications, and to alter it +;; and redistribute it freely, subject to the following +;; restrictions: + +;; 1. The origin of this software must not be misrepresented; you +;; must not claim that you wrote the original software. If you +;; use this software in a product, an acknowledgment in the +;; product documentation would be appreciated but is not +;; required. + +;; 2. Altered source versions must be plainly marked as such, and +;; must not be misrepresented as being the original software. + +;; 3. This notice may not be removed or altered from any source +;; distribution. + +;; This file uses invoke.java from jscheme +;; (http://jscheme.sourceforge.net/jscheme/src/jsint/Invoke.java). +;; The easiest way to use it is to download +;; http://jscheme.sourceforge.net/jscheme/lib/jscheme.jar +;; and add it to the classpath in the file that invokes abcl. + +;; Invoke.java effectively implements dynamic dispatch of java methods. This +;; is used to make it real easy, if perhaps less efficient, to write +;; java code since you don't need to be bothered with imports, or with +;; figuring out which method to call. The only time that you need to +;; know a class name is when you want to call a static method, or a +;; constructor, and in those cases, you only need to know enough of +;; the class name that is unique wrt to the classes on your classpath. +;; +;; Java methods look like this: #"toString". Java classes are +;; represented as symbols, which are resolved to the appropriate java +;; class name. When ambiguous, you need to be more specific. A simple example: + +;; (let ((sw (new 'StringWriter))) +;; (#"write" sw "Hello ") +;; (#"write" sw "World") +;; (print (#"toString" sw))) + +;; What's happened here? First, all the classes in all the jars in the classpath have +;; been collected. For each class a.b.C.d, we have recorded that +;; b.c.d, b.C.d, C.d, c.d, and d potentially refer to this class. In +;; your call to new, as long as the symbol can refer to only one class, we use that +;; class. In this case, it is java.io.StringWriter. You could also have written +;; (new 'io.stringwriter), (new '|io.StringWriter|), (new 'java.io.StringWriter)... + +;; the call (#"write" sw "Hello "), uses the code in invoke.java to +;; call the method named "write" with the arguments sw and "Hello +;; ". Invoke.java figures out the right java method to call, and calls +;; it. + +;; If you want to do a raw java call, use #0"toString". Raw calls +;; return their results as java objects, avoiding doing the usual java +;; object to lisp object conversions that abcl does. + +;; (with-constant-signature ((name jname raw?)*) &body body) +;; binds a macro which expands to a jcall, promising that the same method +;; will be called every time. Use this if you are making a lot of calls and +;; want to avoid the overhead of a the dynamic dispatch. +;; e.g. (with-constant-signature ((tostring "toString")) +;; (time (dotimes (i 10000) (tostring "foo")))) +;; runs about 3x faster than (time (dotimes (i 10000) (#"toString" "foo"))) +;; +;; (with-constant-signature ((tostring "toString" t)) ...) will cause the +;; toString to be a raw java call. see get-all-jar-classnames below for an example. +;; +;; Implementation is that the first time the function is called, the +;; method is looked up based on the arguments passed, and thereafter +;; that method is called directly. Doesn't work for static methods at +;; the moment (lazy) +;; +;; (japropos string) finds all class names matching string +;; (jcmn class-name) lists the names of all methods for the class +;; +;; TODO +;; - Use a package other than common-lisp-user +;; - Make with-constant-signature work for static methods too. +;; - #2"toString" to work like function scoped (with-constant-signature ((tostring "toString")) ...) +;; - #3"toString" to work like runtime scoped (with-constant-signature ((tostring "toString")) ...) +;; (both probably need compiler support to work) +;; - Maybe get rid of second " in reader macro. #"toString looks nicer, but might +;; confuse lisp mode. +;; - write jmap, analogous to map, but can take java collections, java arrays etc. +;; - write loop clauses for java collections. +;; - Register classes in .class files below classpath directories (when :wild-inferiors works) +;; - Make documentation like Edi Weitz +;; +;; Thanks: Peter Graves, Jscheme developers, Mike Travers for skij, +;; Andras Simon for jfli-abcl which bootstrapped me and taught me how to do +;; get-all-jar-classnames +;; + +;; changelog + +;; Sat January 28, 2006, alanr: + +;; Change imports strategy. Only index by last part of class name, +;; case insensitive. Make the lookup-class-name logic be a bit more +;; complicated. This substantially reduces the time it takes to do the +;; auto imports and since class name lookup is relatively infrequent, +;; and in any case cached, this doesn't effect run time speed. (did +;; try caching, but didn't pay - more time was spent reading and +;; populating large hash table) +;; +;; Split class path by ";" in addition to ":" for windows. +;; +;; Tested on windows, linux. + +(in-package :cl-user) + +;; invoke takes it's arguments in a java array. In order to not cons +;; one up each time, but to be thread safe, we allocate a static array +;; of such arrays and save them in threadlocal storage. I'm lazy and +;; so I just assume you will never call a java method with more than +;; *max-java-method-args*. Fix this if it is a problem for you. We +;; don't need to worry about reentrancy as the array is used only +;; between when we call invoke and when invoke calls the actual +;; function you care about. + +(defvar *max-java-method-args* 20 "Increase if you call java methods with more than 20 arguments") + +(defun argvs () + (let ((get (load-time-value (jmethod (jclass "java.lang.ThreadLocal") "get"))) + (argvs (load-time-value (jnew (jconstructor "java.lang.ThreadLocal")))) + (null (load-time-value (make-immediate-object nil :ref)))) + (let ((res (jcall-raw get argvs))) + (if (equal res null) + (let ((it (jnew-array "java.lang.Object" *max-java-method-args*))) + (dotimes (i *max-java-method-args*) + (setf (jarray-ref it i) (jnew-array "java.lang.Object" i))) + (jcall (jmethod (jclass "java.lang.ThreadLocal") "set" "java.lang.Object") + argvs it) + it) + res)))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *do-auto-imports* t)) + +(defvar *imports-resolved-classes* (make-hash-table :test 'equal)) +(defvar *classpath-manager* nil) + + +(defun find-java-class (name) + (jclass (maybe-resolve-class-against-imports name))) + +(defmacro invoke-add-imports (&rest imports) + "push these imports onto the search path. If multiple, earlier in list take precedence" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (clrhash *imports-resolved-classes*) + (dolist (i (reverse ',imports)) + (setq *imports-resolved-classes* (delete i *imports-resolved-classes* :test 'equal)) + ))) + +(defun clear-invoke-imports () + (clrhash *imports-resolved-classes*)) + +(defun maybe-resolve-class-against-imports (classname) + (or (gethash classname *imports-resolved-classes*) + (let ((found (lookup-class-name classname))) + (if found + (progn + (setf (gethash classname *imports-resolved-classes*) found) + found) + (string classname))))) + +(defvar *class-name-to-full-case-insensitive* (make-hash-table :test 'equalp)) + +;; This is the function that calls invoke to call your java method. The first argument is the +;; method name or 'new. The second is the object you are calling it on, followed by the rest of the +;; arguments. If the "object" is a symbol, then that symbol is assumed to be a java class, and +;; a static method on the class is called, otherwise a regular method is called. + +(defun invoke (method object &rest args) + (invoke-restargs method object args)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *invoke-methods* + (load-time-value (jcall (jmethod "java.lang.Class" "getMethods" ) (jclass "jsint.Invoke"))))) + +(defun invoke-restargs (method object args &optional (raw? nil)) + (symbol-macrolet + ((no-argss (load-time-value (jnew-array "java.lang.Object" 0))) + (invoke-class (load-time-value (jclass "jsint.Invoke"))) + (ic (load-time-value (find "invokeConstructor" *invoke-methods* :key 'jmethod-name :test 'equal))) + (is (load-time-value (find "invokeStatic" *invoke-methods* :key 'jmethod-name :test 'equal))) + (ii (load-time-value (find "invokeInstance" *invoke-methods* :key 'jmethod-name :test 'equal))) + (true (load-time-value (make-immediate-object t :boolean))) + (false (load-time-value (make-immediate-object nil :boolean)))) + (let* ( + ;; these two lookups happen before argv is filled, because they themselves call invoke.) + (object-as-class-name (if (symbolp object) (maybe-resolve-class-against-imports object))) + (object-as-class (if object-as-class-name (find-java-class object-as-class-name))) + ) +; (declare (optimize (speed 3) (safety 0))) + (let ((argv (if (null (the list args)) + no-argss + (let ((argv (jarray-ref-raw (argvs) (length (the list args)))) + (i -1)) + (dolist (arg args) + (setf (jarray-ref argv (incf (the fixnum i))) + (if (eq arg t) true (if (eq arg nil) false arg)))) + argv)))) + (if (eq method 'new) + (progn + (jstatic-raw ic invoke-class (or object-as-class-name object) argv)) + (if raw? + (if (symbolp object) + (jstatic-raw is invoke-class object-as-class method argv) + (jstatic-raw ii invoke-class object method argv true)) + (if (symbolp object) + (jstatic is invoke-class object-as-class method argv) + (jstatic ii invoke-class object method argv true) + ))))))) + +;; (defconstant no-args (load-time-value (jnew-array "java.lang.Object" 0))) +;; (defconstant invoke-class (load-time-value (jclass "jsint.Invoke"))) +;; (defconstant ic (load-time-value (find "invokeConstructor" *invoke-methods* :key 'jmethod-name :test 'equal))) +;; (defconstant is (load-time-value (find "invokeStatic" *invoke-methods* :key 'jmethod-name :test 'equal))) +;; (defconstant ii (load-time-value (find "invokeInstance" *invoke-methods* :key 'jmethod-name :test 'equal))) +;; (defconstant true (load-time-value (make-immediate-object t :boolean))) +;; (defconstant false (load-time-value (make-immediate-object nil :boolean))) + +;; (defun invoke-restargs (method object args &optional (raw? nil)) +;; (let* (;; these two lookups happen before argv is filled, because they themselves call invoke. +;; (object-as-class-name (if (symbolp object) (maybe-resolve-class-against-imports object))) +;; (object-as-class (if object-as-class-name (find-java-class object-as-class-name))) +;; ) +;; (declare (optimize (speed 3) (safety 0))) +;; (let ((argv (if (null args) +;; no-args +;; (let ((argv (jarray-ref-raw (argvs) (length args))) +;; (i -1)) +;; (dolist (arg args) +;; (setf (jarray-ref argv (incf (the fixnum i))) +;; (if (eq arg t) true (if (eq arg nil) false arg)))) +;; argv)))) +;; (if (eq method 'new) +;; (progn +;; (jstatic-raw ic invoke-class object-as-class-name argv)) +;; (if raw? +;; (if (symbolp object) +;; (jstatic-raw is invoke-class object-as-class method argv) +;; (jstatic-raw ii invoke-class object method argv true)) +;; (if (symbolp object) +;; (jstatic is invoke-class object-as-class method argv) +;; (jstatic ii invoke-class object method argv true) +;; )))))) + +(defun invoke-find-method (method object args) + (let* ((no-args (load-time-value (jnew-array "java.lang.Object" 0))) + (invoke-class (load-time-value (jclass "jsint.Invoke"))) + (ifm (load-time-value (jmethod (jclass "jsint.Invoke") "findMethod" (jclass "[Ljava.lang.Object;") (jclass "[Ljava.lang.Object;")))) + (imt (load-time-value (find "methodTable" *invoke-methods* :key 'jmethod-name :test 'equal))) + (true (load-time-value (make-immediate-object t :boolean))) + (false (load-time-value (make-immediate-object nil :boolean)))) + (let ((args (if (null args) + no-args + (let ((argv (jarray-ref-raw (argvs) (length args))) + (i -1)) + (dolist (arg args) + (setf (jarray-ref argv (incf i)) + (if (eq arg t) true (if (eq arg nil) false arg)))) + argv)))) + (if (symbolp object) + (jstatic ifm invoke-class (jstatic-raw imt invoke-class (lookup-class-name object) method true true) args) + (jstatic ifm invoke-class (jstatic-raw imt invoke-class (jobject-class object) method false true) args))))) + + +;; This is the reader macro for java methods. it translates the method +;; into a lambda form that calls invoke. Which is nice because you +;; can, e.g. do this: (mapcar #"toString" list-of-java-objects). The reader +;; macro takes one arg. If 0, then jstatic-raw is called, so that abcl doesn't +;; automagically convert the returned java object into a lisp object. So +;; #0"toString" returns a java.lang.String object, where as #"toString" returns +;; a regular lisp string as abcl converts the java string to a lisp string. + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage lambdas (:use)) + (defvar *lcount* 0)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun read-invoke (stream char arg) + (unread-char char stream) + (let ((name (read stream))) + (if (and arg (eql (abs arg) 1)) + (let ((cell (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ; work around bug that gensym here errors when compiling + (object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet + (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas))) + (proclaim `(special ,cell)) + ; (set cell nil) + `(lambda (,object-var &rest ,args-var) + (declare (optimize (speed 3) (safety 0))) + (if (boundp ',cell) ;costing me 10% here because I can't force cell to be bound and hence do null test. + (if (null ,args-var) + (jcall ,cell ,object-var) + (if (null (cdr (the cons ,args-var))) + ,(if (minusp arg) + `(jcall-static ,cell ,object-var (car (the cons ,args-var))) + `(jcall ,cell ,object-var (car (the cons ,args-var)))) + ,(if (minusp arg) + `(apply 'jcall-static ,cell ,object-var (the list ,args-var)) + `(apply 'jcall ,cell ,object-var (the list ,args-var))))) + (progn + (setq ,cell (invoke-find-method ,name ,object-var ,args-var)) + ,(if (minusp arg) + `(apply 'jcall-static ,cell ,object-var ,args-var) + `(apply 'jcall ,cell ,object-var ,args-var)))))) + (let ((object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet + (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas))) + `(lambda (,object-var &rest ,args-var) + (invoke-restargs ,name ,object-var ,args-var ,(eql arg 0))))))) + (set-dispatch-macro-character #\# #\" 'read-invoke)) + +(defmacro with-constant-signature (fname-jname-pairs &body body) + (if (null fname-jname-pairs) + `(progn , at body) + (destructuring-bind ((fname jname &optional raw) &rest ignore) fname-jname-pairs + (declare (ignore ignore)) + (let ((varname (gensym))) + `(let ((,varname nil)) + (macrolet ((,fname (&rest args) + `(if ,',varname + (if ,',raw + (jcall-raw ,',varname , at args) + (jcall ,',varname , at args)) + (progn + (setq ,',varname (invoke-find-method ,',jname ,(car args) (list ,@(rest args)))) + (if ,',raw + (jcall-raw ,',varname , at args) + (jcall ,',varname , at args)))))) + (with-constant-signature ,(cdr fname-jname-pairs) + , at body))))))) + +(defun lookup-class-name (name) + (setq name (string name)) + (let* (;; cant (last-name-pattern (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$")) + ;; reason: bootstrap - the class name would have to be looked up... + (last-name-pattern (load-time-value (jstatic (jmethod "java.util.regex.Pattern" "compile" + (jclass "java.lang.String")) + (jclass "java.util.regex.Pattern") + ".*?([^.]*)$"))) + + (last-name + (let ((matcher (#0"matcher" last-name-pattern name))) + (#"matches" matcher) + (#"group" matcher 1)))) + (let* ((bucket (gethash last-name *class-name-to-full-case-insensitive*)) + (bucket-length (length bucket))) + (or (find name bucket :test 'equalp) + (flet ((matches-end (end full test) + (= (+ (or (search end full :from-end t :test test) -10) + (length end)) + (length full))) + (ambiguous (choices) + (error "Ambiguous class name: ~a can be ~{~a~^, ~}" name choices))) + (if (zerop bucket-length) + name + (let ((matches (loop for el in bucket when (matches-end name el 'char=) collect el))) + (if (= (length matches) 1) + (car matches) + (if (= (length matches) 0) + (let ((matches (loop for el in bucket when (matches-end name el 'char-equal) collect el))) + (if (= (length matches) 1) + (car matches) + (if (= (length matches) 0) + name + (ambiguous matches)))) + (ambiguous matches)))))))))) + +(defun get-all-jar-classnames (jar-file-name) + (let* ((jar (jnew (jconstructor "java.util.jar.JarFile" (jclass "java.lang.String")) (namestring (truename jar-file-name)))) + (entries (#"entries" jar))) + (with-constant-signature ((matcher "matcher" t) (substring "substring") + (jreplace "replace" t) (jlength "length") + (matches "matches") (getname "getName" t) + (next "nextElement" t) (hasmore "hasMoreElements") + (group "group")) + (loop while (hasmore entries) + for name = (getname (next entries)) + with class-pattern = (#"compile" '|java.util.regex.Pattern| "[^$]*\\.class$") + with name-pattern = (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$") + when (matches (matcher class-pattern name)) + collect + (let* ((fullname (substring (jreplace name #\/ #\.) 0 (- (jlength name) 6))) + (matcher (matcher name-pattern fullname)) + (name (progn (matches matcher) (group matcher 1)))) + (cons name fullname)) + )))) + +(defun jar-import (file) + (when (probe-file file) + (loop for (name . full-class-name) in (get-all-jar-classnames file) + do + (pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*) + :test 'equal)))) + + +(defun new (class-name &rest args) + (invoke-restargs 'new class-name args)) + +(defvar *running-in-osgi* (ignore-errors (jclass "org.osgi.framework.BundleActivator"))) + + +(defun get-java-field (object field &optional (try-harder *running-in-osgi*)) + (if try-harder + (let* ((class (if (symbolp object) + (setq object (find-java-class object)) + (if (equal "java.lang.Class" (jclass-name (jobject-class object)) ) + object + (jobject-class object)))) + (jfield (if (java-object-p field) + field + (find field (#"getDeclaredFields" class) :key 'jfield-name :test 'equal)))) + (#"setAccessible" jfield t) + (values (#"get" jfield object) jfield)) + (if (symbolp object) + (let ((class (find-java-class object))) + (#"peekStatic" 'invoke class field)) + (#"peek" 'invoke object field)))) + +;; use #"getSuperclass" and #"getInterfaces" to see whether there are fields in superclasses that we might set +(defun set-java-field (object field value &optional (try-harder *running-in-osgi*)) + (if try-harder + (let* ((class (if (symbolp object) + (setq object (find-java-class object)) + (if (equal "java.lang.Class" (jclass-name (jobject-class object)) ) + object + (jobject-class object)))) + (jfield (if (java-object-p field) + field + (find field (#"getDeclaredFields" class) :key 'jfield-name :test 'equal)))) + (#"setAccessible" jfield t) + (values (#"set" jfield object value) jfield)) + (if (symbolp object) + (let ((class (find-java-class object))) + (#"pokeStatic" 'invoke class field value)) + (#"poke" 'invoke object field value)))) + +(defun find-java-class (name) + (if *classpath-manager* + (or (#1"classForName" *classpath-manager* (maybe-resolve-class-against-imports name)) + (ignore-errors (jclass (maybe-resolve-class-against-imports name)))) + (jclass (maybe-resolve-class-against-imports name)))) + +(defmethod print-object ((obj (jclass "java.lang.Class")) stream) + (print-unreadable-object (obj stream :identity nil) + (format stream "java class ~a" (jclass-name obj)))) + +(defmethod print-object ((obj (jclass "java.lang.reflect.Method")) stream) + (print-unreadable-object (obj stream :identity nil) + (format stream "method ~a" (#"toString" obj)))) + +(defun do-auto-imports () + (flet ((import-class-path (cp) + (map nil + (lambda(s) + (setq s (jcall "toString" s)) + (when *load-verbose* + (format t ";Importing ~a~%" s)) + (cond + ((file-directory-p s) ) + ((equal (pathname-type s) "jar") + (jar-import (merge-pathnames (jcall "toString" s) (format nil "~a/" (jstatic "getProperty" "java.lang.System" "user.dir"))))))) + + (jcall "split" cp (string (jstatic "peekStatic" '|jsint.Invoke| (jclass "java.io.File") "pathSeparatorChar"))) + ))) + (import-class-path (jcall "getClassPath" (jstatic "getRuntimeMXBean" '|java.lang.management.ManagementFactory|))) + (import-class-path (jcall "getBootClassPath" (jstatic "getRuntimeMXBean" '|java.lang.management.ManagementFactory|))) + )) + +(eval-when (:load-toplevel :execute) + (when *do-auto-imports* + (do-auto-imports))) + +(defun japropos (string) + (setq string (string string)) + (let ((matches nil)) + (maphash (lambda(key value) + (declare (ignore key)) + (loop for class in value + when (search string class :test 'string-equal) + do (pushnew (list class "Java Class") matches :test 'equal))) + *class-name-to-full-case-insensitive*) + (loop for (match type) in (sort matches 'string-lessp :key 'car) + do (format t "~a: ~a~%" match type)) + )) + +(defun jclass-method-names (class &optional full) + (if (java-object-p class) + (if (equal (jclass-name (jobject-class class)) "java.lang.Class") + (setq class (jclass-name class)) + (setq class (jclass-name (jobject-class class))))) + (union + (remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getMethods" (find-java-class class))) :test 'equal) + (ignore-errors (remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getConstructors" (find-java-class class))) :test 'equal)))) + +(defun jcmn (class &optional full) + (if full + (dolist (method (jclass-method-names class t)) + (format t "~a~%" method)) + (jclass-method-names class))) + +(defun path-to-class (classname) + (let ((full (lookup-class-name classname))) + (#"toString" + (#"getResource" + (find-java-class full) + (concatenate 'string "/" (substitute #\/ #\. full) ".class"))))) + +;; http://www.javaworld.com/javaworld/javaqa/2003-07/02-qa-0725-classsrc2.html + +(defun all-loaded-classes () + (let ((classes-field + (find "classes" (#"getDeclaredFields" (jclass "java.lang.ClassLoader")) + :key #"getName" :test 'equal))) + (#"setAccessible" classes-field t) + (loop for classloader in + (list* (#"getClassLoader" (jclass "org.armedbear.lisp.Lisp")) + (and *classpath-manager* (list (#"getBaseLoader" *classpath-manager*)))) + append + (loop with classesv = (#"get" classes-field classloader) + for i below (#"size" classesv) + collect (#"getName" (#"elementAt" classesv i))) + append + (loop with classesv = (#"get" classes-field (#"getParent" classloader)) + for i below (#"size" classesv) + collect (#"getName" (#"elementAt" classesv i)))))) + + +;; Modifiy this from Java.java to add a lisp defined classloader. +;; private static Class classForName(String className) throws ClassNotFoundException +;; { +;; try { +;; return Class.forName(className); +;; } +;; catch (ClassNotFoundException e) { +;; return Class.forName(className, true, JavaClassLoader.getPersistentInstance()); +;; } +;; } +;; http://www.javaworld.com/javaworld/jw-10-1996/jw-10-indepth-p2.html + +(defvar *classpath-manager* nil) + +(defvar *added-to-classpath* nil) + +(defun maybe-install-bsh-classloader () + (unless *classpath-manager* + (when (ignore-errors (jclass "bsh.classpath.ClassManagerImpl")) + (let* ((urls (jnew-array "java.net.URL" 0)) + (manager (jnew "bsh.classpath.ClassManagerImpl")) + (bshclassloader (jnew "bsh.classpath.BshClassLoader" manager urls))) + (#"setClassLoader" '|jsint.Import| bshclassloader) + (setq *classpath-manager* manager))))) + +(defun ensure-dynamic-classpath () + (assert *classpath-manager* () "Can't add to classpath unless bean shell jar is in your classpath")) + +(defvar *inhibit-add-to-classpath* nil) + +(defun add-to-classpath (path &optional force) + (unless *inhibit-add-to-classpath* + (ensure-dynamic-classpath) + (clear-invoke-imports) + (let ((absolute (namestring (truename path)))) +;; (when (not (equal (pathname-type absolute) (pathname-type path))) +;; (warn "HEY! ~a, ~a ~a, ~a" path (pathname-type path) absolute (pathname-type absolute)) +;; (setq @ (list path absolute))) + ;; NOTE: for jar files, specified as a component, the ".jar" is part of the pathname-name :( + (when (or force (not (member absolute *added-to-classpath* :test 'equalp))) + (#"addClassPath" *classpath-manager* (new 'java.net.url (#"replaceAll" (#"replaceAll" (concatenate 'string "file://" absolute) "\\\\" "/") "C:" ""))) + (#"setClassLoader" '|jsint.Import| (#"getBaseLoader" *classpath-manager*)) +; (format t "path=~a type=~a~%" absolute (pathname-type absolute)) + (cond ((equal (pathname-type absolute) "jar") + (jar-import absolute)) + ((file-directory-p absolute) + (classfiles-import absolute))) + (push absolute *added-to-classpath*))))) + +(defun get-dynamic-class-path () + (ensure-dynamic-classpath) + (map 'list (lambda(el) + (let ((path (#"toString" el))) + (if (eql (search "file:/" path) 0) + (subseq path 5) + path))) + (#"getPathComponents" (#"getClassPath" *classpath-manager*)))) + +(eval-when (:load-toplevel :execute) + (maybe-install-bsh-classloader)) + + + +; http://java.sun.com/j2se/1.5.0/docs/api/java/lang/management/MemoryMXBean.html +; http://java.sun.com/docs/hotspot/gc/ +; http://www.javaworld.com/javaworld/jw-01-2002/jw-0111-hotspotgc-p2.html +; http://java.sun.com/docs/hotspot/VMOptions.html +; http://java.sun.com/docs/hotspot/gc5.0/gc_tuning_5.html +; http://java.sun.com/docs/hotspot/gc1.4.2/faq.html +; http://java.sun.com/developer/technicalArticles/Programming/turbo/ +;-XX:MinFreeHeapRatio= +;-XX:MaxHeapFreeRatio= +;-XX:NewRatio= +;-XX:SurvivorRatio= +;-XX:SoftRefLRUPolicyMSPerMB=10000 +;-XX:+PrintTenuringDistribution +;-XX:MaxLiveObjectEvacuationRatio + + +(defun java-gc () + (#"gc" (#"getRuntime" 'java.lang.runtime)) + (#"runFinalization" (#"getRuntime" 'java.lang.runtime)) + (#"gc" (#"getRuntime" 'java.lang.runtime)) + (java-room)) + +(defun java-room () + (let ((rt (#"getRuntime" 'java.lang.runtime))) + (values (- (#"totalMemory" rt) (#"freeMemory" rt)) + (#"totalMemory" rt) + (#"freeMemory" rt) + (list :used :total :free)))) + +(defun verbose-gc (&optional (new-value nil new-value-supplied)) + (if new-value-supplied + (progn (#"setVerbose" (#"getMemoryMXBean" 'java.lang.management.ManagementFactory) new-value) new-value) + (#"isVerbose" (#"getMemoryMXBean" 'java.lang.management.ManagementFactory)))) + +(defun all-jars-below (directory) + (loop with q = (system:list-directory directory) + while q for top = (pop q) + if (null (pathname-name top)) do (setq q (append q (all-jars-below top))) + if (equal (pathname-type top) "jar") collect top)) + +(defun all-classfiles-below (directory) + (loop with q = (system:list-directory directory) + while q for top = (pop q) + if (null (pathname-name top)) do (setq q (append q (all-classfiles-below top ))) + if (equal (pathname-type top) "class") + collect top + )) + +(defun all-classes-below-directory (directory) + (loop for file in (all-classfiles-below directory) collect + (format nil "~{~a.~}~a" + (subseq (pathname-directory file) (length (pathname-directory directory))) + (pathname-name file)) + )) + +(defun classfiles-import (directory) + (setq directory (truename directory)) + (loop for full-class-name in (all-classes-below-directory directory) + for name = (#"replaceAll" full-class-name "^.*\\." "") + do + (pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*) + :test 'equal))) + +(defun add-directory-jars-to-class-path (directory recursive-p) + (if recursive-p + (loop for jar in (all-jars-below directory) do (cl-user::add-to-classpath jar)) + (loop for jar in (directory (merge-pathnames "*.jar" directory)) do (cl-user::add-to-classpath jar)))) + +(defun need-to-add-directory-jar? (directory recursive-p) + (if recursive-p + (loop for jar in (all-jars-below directory) + do + (if (not (member (namestring (truename jar)) *added-to-classpath* :test 'equal)) + (return-from need-to-add-directory-jar? t))) + (loop for jar in (directory (merge-pathnames "*.jar" directory)) + do + (if (not (member (namestring (truename jar)) *added-to-classpath* :test 'equal)) + (return-from need-to-add-directory-jar? t)))) + nil) + +(defun set-to-list (set) + (declare (optimize (speed 3) (safety 0))) + (with-constant-signature ((iterator "iterator" t) (hasnext "hasNext") (next "next")) + (loop with iterator = (iterator set) + while (hasNext iterator) + for item = (next iterator) + collect item))) + +(defun list-to-list (list) + (declare (optimize (speed 3) (safety 0))) + (with-constant-signature ((isEmpty "isEmpty") (getfirst "getFirst") + (getNext "getNext")) + (loop until (isEmpty list) + collect (getFirst list) + do (setq list (getNext list))))) + +;; Contribution of Luke Hope. (Thanks!) + +(defun iterable-to-list (iterable) + (declare (optimize (speed 3) (safety 0))) + (let ((it (#"iterator" iterable))) + (with-constant-signature ((hasmore "hasMoreElements") + (next "nextElement")) + (loop while (hasmore it) + collect (next it))))) + +(defun vector-to-list (vector) + (declare (optimize (speed 3) (safety 0))) + (with-constant-signature ((hasmore "hasMoreElements") + (next "nextElement")) + (loop while (hasmore vector) + collect (next vector)))) + +(defun hashmap-to-hashtable (hashmap &rest rest &key (keyfun #'identity) (valfun #'identity) (invert? nil) + table + &allow-other-keys ) + (let ((keyset (#"keySet" hashmap)) + (table (or table (apply 'make-hash-table + (loop for (key value) on rest by #'cddr + unless (member key '(:invert? :valfun :keyfun :table)) + collect key and collect value))))) + (with-constant-signature ((iterator "iterator" t) (hasnext "hasNext") (next "next")) + (loop with iterator = (iterator keyset) + while (hasNext iterator) + for item = (next iterator) + do (if invert? + (setf (gethash (funcall valfun (#"get" hashmap item)) table) (funcall keyfun item)) + (setf (gethash (funcall keyfun item) table) (funcall valfun (#"get" hashmap item))))) + table))) + +(defun jclass-all-interfaces (class) + "Return a list of interfaces the class implements" + (unless (java-object-p class) + (setq class (find-java-class class))) + (loop for aclass = class then (#"getSuperclass" aclass) + while aclass + append (coerce (#"getInterfaces" aclass) 'list))) + +(defun safely (f name) + (let ((fname (gensym))) + (compile fname + `(lambda(&rest args) + (with-simple-restart (top-level + "Return from lisp method implementation for ~a." ,name) + (apply ,f args)))) + (symbol-function fname))) + +(defun jdelegating-interface-implementation (interface dispatch-to &rest method-names-and-defs) + "Creates and returns an implementation of a Java interface with + methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS. + + INTERFACE is an interface + + DISPATCH-TO is an existing Java object + + METHOD-NAMES-AND-DEFS is an alternating list of method names + (strings) and method definitions (closures). + + For missing methods, a dummy implementation is provided that + calls the method on DISPATCH-TO" + (let ((implemented-methods + (loop for m in method-names-and-defs + for i from 0 + if (evenp i) + do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m + else + do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m))) + (null (make-immediate-object nil :ref))) + (let ((safe-method-names-and-defs + (loop for (name function) on method-names-and-defs by #'cddr + collect name collect (safely function name)))) + (loop for method across + (jclass-methods interface :declared nil :public t) + for method-name = (jmethod-name method) + when (not (member method-name implemented-methods :test #'string=)) + do + (let* ((def `(lambda + (&rest args) + (cl-user::invoke-restargs ,(jmethod-name method) ,dispatch-to args t) + ))) + (push (coerce def 'function) safe-method-names-and-defs) + (push method-name safe-method-names-and-defs))) + (apply #'java::%jnew-proxy interface safe-method-names-and-defs)))) + + +(defun java-exception-report (condition) + (if (and (typep condition 'java-exception) + (java-exception-cause condition) + (equal (jclass-name (jobject-class (java-exception-cause condition))) + "jsint.BacktraceException")) + (with-output-to-string (s) + (let ((writer (new 'stringwriter))) + (#"printStackTrace" (#"getBaseException"(java-exception-cause condition)) (new 'printwriter writer)) + (write-string (#"replaceFirst" (#"toString" writer) "(?s)\\s*at sun.reflect.*" "") s)) + ) + (#"replaceFirst" (princ-to-string condition) "(?s)\\\\s*at jsint.E.*" ""))) + +(in-package :asdf) + + +(defclass jar-directory (static-file) ()) + +(defmethod perform ((operation compile-op) (c jar-directory)) + (unless cl-user::*inhibit-add-to-classpath* + (cl-user::add-directory-jars-to-class-path (truename (component-pathname c)) t))) + +(defmethod perform ((operation load-op) (c jar-directory)) + (unless cl-user::*inhibit-add-to-classpath* + (cl-user::add-directory-jars-to-class-path (truename (component-pathname c)) t))) + +(defmethod operation-done-p ((operation load-op) (c jar-directory)) + (or cl-user::*inhibit-add-to-classpath* + (not (cl-user::need-to-add-directory-jar? (component-pathname c) t)))) + +(defmethod operation-done-p ((operation compile-op) (c jar-directory)) + t) + +(defclass jar-file (static-file) ()) + +(defmethod perform ((operation compile-op) (c jar-file)) + (cl-user::add-to-classpath (component-pathname c))) + +(defmethod perform ((operation load-op) (c jar-file)) + (or cl-user::*inhibit-add-to-classpath* + (cl-user::add-to-classpath (component-pathname c)))) + +(defmethod operation-done-p ((operation load-op) (c jar-file)) + (or cl-user::*inhibit-add-to-classpath* + (member (namestring (truename (component-pathname c))) cl-user::*added-to-classpath* :test 'equal))) + +(defmethod operation-done-p ((operation compile-op) (c jar-file)) + t) + +(defclass class-file-directory (static-file) ()) + +(defmethod perform ((operation compile-op) (c class-file-directory)) + (cl-user::add-to-classpath (component-pathname c))) + +(defmethod perform ((operation load-op) (c class-file-directory)) + (cl-user::add-to-classpath (component-pathname c))) + +;; **************************************************************** + + + Added: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jss/jss.asd Fri May 20 07:24:30 2011 (r13280) @@ -0,0 +1,12 @@ +;;;; -*- Mode: LISP -*- + +(in-package :asdf) + +(defsystem :jss + :author "Alan Ruttenberg" + :version "1" + :components + ((:file "invoke")) + :depends-on + ()) + From mevenson at common-lisp.net Sat Jun 4 20:25:24 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:24 -0700 Subject: [armedbear-cvs] r13281 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Fri May 20 07:24:57 2011 New Revision: 13281 Log: Provisionally working version of JSS without bsh-2.0b4.jar. This still needs 'jscheme.jar' to be loaded via the top-level declaration at the beginning of packages.lisp. Adjust the filepath to a local version of jscheme.jar which may be downloaded from http://code.google.com/p/lsw2/source/browse/trunk/lib/jscheme.jar. Rigourously untested, but still a worthwhile checkpoint for public consumption, especially since we need to fix on an API. Re-packaged in JSS package. Use ENSURE-COMPATIBILITY to be compatible with existing JSS installations. Added: trunk/abcl/contrib/jss/asdf-jar.lisp trunk/abcl/contrib/jss/compat.lisp trunk/abcl/contrib/jss/packages.lisp Modified: trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/jss.asd Added: trunk/abcl/contrib/jss/asdf-jar.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jss/asdf-jar.lisp Fri May 20 07:24:57 2011 (r13281) @@ -0,0 +1,50 @@ +(in-package :asdf) + +(defclass jar-directory (static-file) ()) + +(defmethod perform ((operation compile-op) (c jar-directory)) + (unless jss:*inhibit-add-to-classpath* + (jss:add-directory-jars-to-class-path (truename (component-pathname c)) t))) + +(defmethod perform ((operation load-op) (c jar-directory)) + (unless jss:*inhibit-add-to-classpath* + (jss:add-directory-jars-to-class-path (truename (component-pathname c)) t))) + +(defmethod operation-done-p ((operation load-op) (c jar-directory)) + (or jss:*inhibit-add-to-classpath* + (not (jss:need-to-add-directory-jar? (component-pathname c) t)))) + +(defmethod operation-done-p ((operation compile-op) (c jar-directory)) + t) + +(defclass jar-file (static-file) ()) + +(defmethod perform ((operation compile-op) (c jar-file)) + (jss:add-to-classpath (component-pathname c))) + +(defmethod perform ((operation load-op) (c jar-file)) + (or jss:*inhibit-add-to-classpath* + (jss::add-to-classpath (component-pathname c)))) + +(defmethod operation-done-p ((operation load-op) (c jar-file)) + t +#+nil + (or jss:*inhibit-add-to-classpath* + (member (namestring (truename (component-pathname c))) jss:*added-to-classpath* :test 'equal))) + +(defmethod operation-done-p ((operation compile-op) (c jar-file)) + t) + +(defclass class-file-directory (static-file) ()) + +(defmethod perform ((operation compile-op) (c class-file-directory)) + (jss:add-to-classpath (component-pathname c))) + +(defmethod perform ((operation load-op) (c class-file-directory)) + (jss:add-to-classpath (component-pathname c))) + +(defmethod source-file-type ((c jar-file) (s module)) "jar") + + + + Added: trunk/abcl/contrib/jss/compat.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jss/compat.lisp Fri May 20 07:24:57 2011 (r13281) @@ -0,0 +1,12 @@ +(in-package :jss) + +(defparameter *cl-user-compatibility* nil + "Whether backwards compatiblity with JSS's use of CL-USER has been enabled.") + +(defun ensure-compatiblity () + (setf *cl-user-compatibility* t) + (dolist (symbol '(get-java-field)) + (unintern symbol :cl-user) + (import symbol :cl-user))) + + Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Fri May 20 07:24:30 2011 (r13280) +++ trunk/abcl/contrib/jss/invoke.lisp Fri May 20 07:24:57 2011 (r13281) @@ -120,7 +120,7 @@ ;; ;; Tested on windows, linux. -(in-package :cl-user) +(in-package :jss) ;; invoke takes it's arguments in a java array. In order to not cons ;; one up each time, but to be thread safe, we allocate a static array @@ -152,7 +152,6 @@ (defvar *do-auto-imports* t)) (defvar *imports-resolved-classes* (make-hash-table :test 'equal)) -(defvar *classpath-manager* nil) (defun find-java-class (name) @@ -216,16 +215,14 @@ (if (eq arg t) true (if (eq arg nil) false arg)))) argv)))) (if (eq method 'new) - (progn - (jstatic-raw ic invoke-class (or object-as-class-name object) argv)) + (apply #'jnew (or object-as-class-name object) args) (if raw? (if (symbolp object) - (jstatic-raw is invoke-class object-as-class method argv) - (jstatic-raw ii invoke-class object method argv true)) + (apply #'jstatic-raw method object-as-class args) + (apply #'jcall-raw method object args)) (if (symbolp object) - (jstatic is invoke-class object-as-class method argv) - (jstatic ii invoke-class object method argv true) - ))))))) + (apply #'jstatic method object-as-class args) + (apply #'jcall method object args)))))))) ;; (defconstant no-args (load-time-value (jnew-array "java.lang.Object" 0))) ;; (defconstant invoke-class (load-time-value (jclass "jsint.Invoke"))) @@ -410,7 +407,6 @@ (pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*) :test 'equal)))) - (defun new (class-name &rest args) (invoke-restargs 'new class-name args)) @@ -431,8 +427,8 @@ (values (#"get" jfield object) jfield)) (if (symbolp object) (let ((class (find-java-class object))) - (#"peekStatic" 'invoke class field)) - (#"peek" 'invoke object field)))) + (jfield class field) + (jfield field object))))) ;; use #"getSuperclass" and #"getInterfaces" to see whether there are fields in superclasses that we might set (defun set-java-field (object field value &optional (try-harder *running-in-osgi*)) @@ -452,11 +448,16 @@ (#"pokeStatic" 'invoke class field value)) (#"poke" 'invoke object field value)))) +(defconstant +for-name+ + (jmethod "java.lang.Class" "forName" "java.lang.String" "boolean" "java.lang.ClassLoader")) + +(defconstant +true+ + (jstatic-raw "parseBoolean" "java.lang.Boolean" "true")) + (defun find-java-class (name) - (if *classpath-manager* - (or (#1"classForName" *classpath-manager* (maybe-resolve-class-against-imports name)) - (ignore-errors (jclass (maybe-resolve-class-against-imports name)))) - (jclass (maybe-resolve-class-against-imports name)))) + (or (jstatic +for-name+ "java.lang.Class" + (maybe-resolve-class-against-imports name) +true+ java::*classloader*) + (ignore-errors (jclass (maybe-resolve-class-against-imports name))))) (defmethod print-object ((obj (jclass "java.lang.Class")) stream) (print-unreadable-object (obj stream :identity nil) @@ -530,9 +531,7 @@ (find "classes" (#"getDeclaredFields" (jclass "java.lang.ClassLoader")) :key #"getName" :test 'equal))) (#"setAccessible" classes-field t) - (loop for classloader in - (list* (#"getClassLoader" (jclass "org.armedbear.lisp.Lisp")) - (and *classpath-manager* (list (#"getBaseLoader" *classpath-manager*)))) + (loop for classloader in (mapcar #'first (dump-classpath)) append (loop with classesv = (#"get" classes-field classloader) for i below (#"size" classesv) @@ -555,37 +554,24 @@ ;; } ;; http://www.javaworld.com/javaworld/jw-10-1996/jw-10-indepth-p2.html -(defvar *classpath-manager* nil) - (defvar *added-to-classpath* nil) -(defun maybe-install-bsh-classloader () - (unless *classpath-manager* - (when (ignore-errors (jclass "bsh.classpath.ClassManagerImpl")) - (let* ((urls (jnew-array "java.net.URL" 0)) - (manager (jnew "bsh.classpath.ClassManagerImpl")) - (bshclassloader (jnew "bsh.classpath.BshClassLoader" manager urls))) - (#"setClassLoader" '|jsint.Import| bshclassloader) - (setq *classpath-manager* manager))))) - -(defun ensure-dynamic-classpath () - (assert *classpath-manager* () "Can't add to classpath unless bean shell jar is in your classpath")) - (defvar *inhibit-add-to-classpath* nil) (defun add-to-classpath (path &optional force) (unless *inhibit-add-to-classpath* - (ensure-dynamic-classpath) - (clear-invoke-imports) +;;; (ensure-dynamic-classpath) +;;; (clear-invoke-imports) (let ((absolute (namestring (truename path)))) ;; (when (not (equal (pathname-type absolute) (pathname-type path))) ;; (warn "HEY! ~a, ~a ~a, ~a" path (pathname-type path) absolute (pathname-type absolute)) ;; (setq @ (list path absolute))) ;; NOTE: for jar files, specified as a component, the ".jar" is part of the pathname-name :( (when (or force (not (member absolute *added-to-classpath* :test 'equalp))) - (#"addClassPath" *classpath-manager* (new 'java.net.url (#"replaceAll" (#"replaceAll" (concatenate 'string "file://" absolute) "\\\\" "/") "C:" ""))) - (#"setClassLoader" '|jsint.Import| (#"getBaseLoader" *classpath-manager*)) +;;; (#"addClassPath" *classpath-manager* (new 'java.net.url (#"replaceAll" (#"replaceAll" (concatenate 'string "file://" absolute) "\\\\" "/") "C:" ""))) +;;; (#"setClassLoader" '|jsint.Import| (#"getBaseLoader" *classpath-manager*)) ; (format t "path=~a type=~a~%" absolute (pathname-type absolute)) + (java:add-to-classpath path) (cond ((equal (pathname-type absolute) "jar") (jar-import absolute)) ((file-directory-p absolute) @@ -593,7 +579,8 @@ (push absolute *added-to-classpath*))))) (defun get-dynamic-class-path () - (ensure-dynamic-classpath) + (dump-classpath) +#+nil (map 'list (lambda(el) (let ((path (#"toString" el))) (if (eql (search "file:/" path) 0) @@ -601,6 +588,7 @@ path))) (#"getPathComponents" (#"getClassPath" *classpath-manager*)))) +#+nil (eval-when (:load-toplevel :execute) (maybe-install-bsh-classloader)) @@ -671,8 +659,8 @@ (defun add-directory-jars-to-class-path (directory recursive-p) (if recursive-p - (loop for jar in (all-jars-below directory) do (cl-user::add-to-classpath jar)) - (loop for jar in (directory (merge-pathnames "*.jar" directory)) do (cl-user::add-to-classpath jar)))) + (loop for jar in (all-jars-below directory) do (add-to-classpath jar)) + (loop for jar in (directory (merge-pathnames "*.jar" directory)) do (add-to-classpath jar)))) (defun need-to-add-directory-jar? (directory recursive-p) (if recursive-p @@ -773,10 +761,10 @@ do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m else do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m))) - (null (make-immediate-object nil :ref))) +#+nil (null (make-immediate-object nil :ref))) (let ((safe-method-names-and-defs (loop for (name function) on method-names-and-defs by #'cddr - collect name collect (safely function name)))) + collect name collect (safely function name)))) (loop for method across (jclass-methods interface :declared nil :public t) for method-name = (jmethod-name method) @@ -784,7 +772,7 @@ do (let* ((def `(lambda (&rest args) - (cl-user::invoke-restargs ,(jmethod-name method) ,dispatch-to args t) + (invoke-restargs ,(jmethod-name method) ,dispatch-to args t) ))) (push (coerce def 'function) safe-method-names-and-defs) (push method-name safe-method-names-and-defs))) @@ -803,51 +791,3 @@ ) (#"replaceFirst" (princ-to-string condition) "(?s)\\\\s*at jsint.E.*" ""))) -(in-package :asdf) - - -(defclass jar-directory (static-file) ()) - -(defmethod perform ((operation compile-op) (c jar-directory)) - (unless cl-user::*inhibit-add-to-classpath* - (cl-user::add-directory-jars-to-class-path (truename (component-pathname c)) t))) - -(defmethod perform ((operation load-op) (c jar-directory)) - (unless cl-user::*inhibit-add-to-classpath* - (cl-user::add-directory-jars-to-class-path (truename (component-pathname c)) t))) - -(defmethod operation-done-p ((operation load-op) (c jar-directory)) - (or cl-user::*inhibit-add-to-classpath* - (not (cl-user::need-to-add-directory-jar? (component-pathname c) t)))) - -(defmethod operation-done-p ((operation compile-op) (c jar-directory)) - t) - -(defclass jar-file (static-file) ()) - -(defmethod perform ((operation compile-op) (c jar-file)) - (cl-user::add-to-classpath (component-pathname c))) - -(defmethod perform ((operation load-op) (c jar-file)) - (or cl-user::*inhibit-add-to-classpath* - (cl-user::add-to-classpath (component-pathname c)))) - -(defmethod operation-done-p ((operation load-op) (c jar-file)) - (or cl-user::*inhibit-add-to-classpath* - (member (namestring (truename (component-pathname c))) cl-user::*added-to-classpath* :test 'equal))) - -(defmethod operation-done-p ((operation compile-op) (c jar-file)) - t) - -(defclass class-file-directory (static-file) ()) - -(defmethod perform ((operation compile-op) (c class-file-directory)) - (cl-user::add-to-classpath (component-pathname c))) - -(defmethod perform ((operation load-op) (c class-file-directory)) - (cl-user::add-to-classpath (component-pathname c))) - -;; **************************************************************** - - - Modified: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- trunk/abcl/contrib/jss/jss.asd Fri May 20 07:24:30 2011 (r13280) +++ trunk/abcl/contrib/jss/jss.asd Fri May 20 07:24:57 2011 (r13281) @@ -1,12 +1,23 @@ ;;;; -*- Mode: LISP -*- +;;; XXX +;;(java:add-to-classpath "~/work/lsw2/lib/jscheme.jar") + (in-package :asdf) (defsystem :jss :author "Alan Ruttenberg" - :version "1" - :components - ((:file "invoke")) - :depends-on - ()) + :version "2.0" + :components + ((:module base :pathname "" :serial t + :components ((:file "packages") + (:file "invoke") + (:file "asdf-jar") + (:file "compat"))))) + + + + + + Added: trunk/abcl/contrib/jss/packages.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jss/packages.lisp Fri May 20 07:24:57 2011 (r13281) @@ -0,0 +1,21 @@ +(defpackage :jss + (:nicknames "java-simple-syntax" "java-syntax-sucks") + (:use :common-lisp :extensions :java) + (:export + #:*inhibit-add-to-classpath* + #:*added-to-classpath* + #:add-to-classpath + #:new + #:need-to-add-directory-jar? + #:add-directory-jars-to-class-path + +;;; compatibility + #:ensure-compatiblity #:*cl-user-compatibility* + #:get-java-field) + (:shadow #:add-to-classpath)) + +(eval-when (:compile-toplevel :load-toplevel) + (java:add-to-classpath + (merge-pathnames "../../../lsw2/lib/jscheme.jar" (asdf:component-pathname (asdf:find-system :jss))))) + + From mevenson at common-lisp.net Sat Jun 4 20:25:29 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:29 -0700 Subject: [armedbear-cvs] r13282 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat May 21 05:40:49 2011 New Revision: 13282 Log: Make JAVA:JRESOLVE-METHOD try harder to resolve a JAVA-OBJECT instance. Unclear if this behavior comes from a bug in how we intialize JAVA-OBJECT's intendedClass or is a "natural" result of some casting assumption. We assume that users of JRESOLVE-METHOD would prefer some sort of callable result as opposed to NIL as the current JAVA introspection APIs assumption seems to geared to guessing a reasonable default. Those wishing strict introspection semantics are advised to use the java.lang.reflect package directly. 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 Fri May 20 07:24:57 2011 (r13281) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Sat May 21 05:40:49 2011 (r13282) @@ -771,13 +771,12 @@ }; private static final Primitive JRESOLVE_METHOD = new pf_jresolve_method(); - @DocString(name="jresolve_method", args="method-name instance &rest args", + @DocString(name="jresolve-method", args="method-name instance &rest args", doc="Finds the most specific Java method METHOD-NAME on INSTANCE " + "applicable to arguments ARGS. Returns NIL if no suitable method is " + "found. The algorithm used for resolution is the same used by JCALL " + "when it is called with a string as the first parameter (METHOD-REF).") private static final class pf_jresolve_method extends Primitive { - pf_jresolve_method() { super(Symbol.JRESOLVE_METHOD); } @@ -808,6 +807,18 @@ Method method = findMethod(instance, intendedClass, methodName, methodArgs); if (method != null) { return JavaObject.getInstance(method); + } else if (instanceArg instanceof JavaObject) { + // Sometimes JavaObject.intendedClass has the default + // value java.lang.Object, so we try again to resolve + // the method using a dynamically requested value for + // java.lang.Class. + intendedClass = ((JavaObject)instanceArg).getObject().getClass(); + method = findMethod(instance, intendedClass, methodName, methodArgs); + } else { + return NIL; + } + if (method != null) { + return JavaObject.getInstance(method); } else { return NIL; } From mevenson at common-lisp.net Sat Jun 4 20:25:33 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:33 -0700 Subject: [armedbear-cvs] r13283 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Sat May 21 05:41:09 2011 New Revision: 13283 Log: Removed dependency on jscheme.jar. Now standalone! Needs substantial testing, vigorous pruning of orphaned code, and optimization of "new" calling procedures (especially the memoization facility of INVOKE-FIND-METHOD. Modified: trunk/abcl/contrib/jss/compat.lisp trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/jss.asd trunk/abcl/contrib/jss/packages.lisp Modified: trunk/abcl/contrib/jss/compat.lisp ============================================================================== --- trunk/abcl/contrib/jss/compat.lisp Sat May 21 05:40:49 2011 (r13282) +++ trunk/abcl/contrib/jss/compat.lisp Sat May 21 05:41:09 2011 (r13283) @@ -5,7 +5,7 @@ (defun ensure-compatiblity () (setf *cl-user-compatibility* t) - (dolist (symbol '(get-java-field)) + (dolist (symbol '(get-java-field new)) (unintern symbol :cl-user) (import symbol :cl-user))) Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Sat May 21 05:40:49 2011 (r13282) +++ trunk/abcl/contrib/jss/invoke.lisp Sat May 21 05:41:09 2011 (r13283) @@ -120,6 +120,9 @@ ;; ;; Tested on windows, linux. +;; 2011-05-21 Mark Evenson +;; "ported" to native ABCL without needing the jscheme.jar or bsh-2.0b4.jar + (in-package :jss) ;; invoke takes it's arguments in a java array. In order to not cons @@ -192,91 +195,56 @@ (load-time-value (jcall (jmethod "java.lang.Class" "getMethods" ) (jclass "jsint.Invoke"))))) (defun invoke-restargs (method object args &optional (raw? nil)) - (symbol-macrolet - ((no-argss (load-time-value (jnew-array "java.lang.Object" 0))) - (invoke-class (load-time-value (jclass "jsint.Invoke"))) - (ic (load-time-value (find "invokeConstructor" *invoke-methods* :key 'jmethod-name :test 'equal))) - (is (load-time-value (find "invokeStatic" *invoke-methods* :key 'jmethod-name :test 'equal))) - (ii (load-time-value (find "invokeInstance" *invoke-methods* :key 'jmethod-name :test 'equal))) - (true (load-time-value (make-immediate-object t :boolean))) - (false (load-time-value (make-immediate-object nil :boolean)))) - (let* ( - ;; these two lookups happen before argv is filled, because they themselves call invoke.) - (object-as-class-name (if (symbolp object) (maybe-resolve-class-against-imports object))) - (object-as-class (if object-as-class-name (find-java-class object-as-class-name))) - ) -; (declare (optimize (speed 3) (safety 0))) - (let ((argv (if (null (the list args)) - no-argss - (let ((argv (jarray-ref-raw (argvs) (length (the list args)))) - (i -1)) - (dolist (arg args) - (setf (jarray-ref argv (incf (the fixnum i))) - (if (eq arg t) true (if (eq arg nil) false arg)))) - argv)))) - (if (eq method 'new) - (apply #'jnew (or object-as-class-name object) args) - (if raw? - (if (symbolp object) - (apply #'jstatic-raw method object-as-class args) - (apply #'jcall-raw method object args)) - (if (symbolp object) - (apply #'jstatic method object-as-class args) - (apply #'jcall method object args)))))))) - -;; (defconstant no-args (load-time-value (jnew-array "java.lang.Object" 0))) -;; (defconstant invoke-class (load-time-value (jclass "jsint.Invoke"))) -;; (defconstant ic (load-time-value (find "invokeConstructor" *invoke-methods* :key 'jmethod-name :test 'equal))) -;; (defconstant is (load-time-value (find "invokeStatic" *invoke-methods* :key 'jmethod-name :test 'equal))) -;; (defconstant ii (load-time-value (find "invokeInstance" *invoke-methods* :key 'jmethod-name :test 'equal))) -;; (defconstant true (load-time-value (make-immediate-object t :boolean))) -;; (defconstant false (load-time-value (make-immediate-object nil :boolean))) - -;; (defun invoke-restargs (method object args &optional (raw? nil)) -;; (let* (;; these two lookups happen before argv is filled, because they themselves call invoke. -;; (object-as-class-name (if (symbolp object) (maybe-resolve-class-against-imports object))) -;; (object-as-class (if object-as-class-name (find-java-class object-as-class-name))) -;; ) -;; (declare (optimize (speed 3) (safety 0))) -;; (let ((argv (if (null args) -;; no-args -;; (let ((argv (jarray-ref-raw (argvs) (length args))) -;; (i -1)) -;; (dolist (arg args) -;; (setf (jarray-ref argv (incf (the fixnum i))) -;; (if (eq arg t) true (if (eq arg nil) false arg)))) -;; argv)))) -;; (if (eq method 'new) -;; (progn -;; (jstatic-raw ic invoke-class object-as-class-name argv)) -;; (if raw? -;; (if (symbolp object) -;; (jstatic-raw is invoke-class object-as-class method argv) -;; (jstatic-raw ii invoke-class object method argv true)) -;; (if (symbolp object) -;; (jstatic is invoke-class object-as-class method argv) -;; (jstatic ii invoke-class object method argv true) -;; )))))) + (let* ((object-as-class-name + (if (symbolp object) (maybe-resolve-class-against-imports object))) + (object-as-class + (if object-as-class-name (find-java-class object-as-class-name)))) + (if (eq method 'new) + (apply #'jnew (or object-as-class-name object) args) + (if raw? + (if (symbolp object) + (apply #'jstatic-raw method object-as-class args) + (apply #'jcall-raw method object args)) + (if (symbolp object) + (apply #'jstatic method object-as-class args) + (apply #'jcall method object args)))))) + +;;; Method name --> Object --> jmethod +;;; +(defvar *methods-cache* (make-hash-table :test #'equal)) + +(defun get-jmethod (method object) + (when (gethash method *methods-cache*) + (gethash + (if (symbolp object) (lookup-class-name object) (jobject-class object)) + (gethash method *methods-cache*)))) + +(defun set-jmethod (method object jmethod) + (unless (gethash method *methods-cache*) + (setf (gethash method *methods-cache*) (make-hash-table :test #'equal))) + (setf + (gethash + (if (symbolp object) (lookup-class-name object) (jobject-class object)) + (gethash method *methods-cache*)) + jmethod)) +(defparameter *last-invoke-find-method-args* nil) +;;; TODO optimize me! (defun invoke-find-method (method object args) - (let* ((no-args (load-time-value (jnew-array "java.lang.Object" 0))) - (invoke-class (load-time-value (jclass "jsint.Invoke"))) - (ifm (load-time-value (jmethod (jclass "jsint.Invoke") "findMethod" (jclass "[Ljava.lang.Object;") (jclass "[Ljava.lang.Object;")))) - (imt (load-time-value (find "methodTable" *invoke-methods* :key 'jmethod-name :test 'equal))) - (true (load-time-value (make-immediate-object t :boolean))) - (false (load-time-value (make-immediate-object nil :boolean)))) - (let ((args (if (null args) - no-args - (let ((argv (jarray-ref-raw (argvs) (length args))) - (i -1)) - (dolist (arg args) - (setf (jarray-ref argv (incf i)) - (if (eq arg t) true (if (eq arg nil) false arg)))) - argv)))) - (if (symbolp object) - (jstatic ifm invoke-class (jstatic-raw imt invoke-class (lookup-class-name object) method true true) args) - (jstatic ifm invoke-class (jstatic-raw imt invoke-class (jobject-class object) method false true) args))))) - + (setf *last-invoke-find-method-args* (list method object args)) + (let ((jmethod (get-jmethod method object))) + (unless jmethod + (setf jmethod + (if (symbolp object) + ;;; static method + (apply #'jmethod (lookup-class-name object) + method (mapcar #'jobject-class args)) + ;;; instance method + (apply #'jresolve-method + method object args))) + (jcall "setAccessible" jmethod +true+) + (set-jmethod method object jmethod)) + jmethod)) ;; This is the reader macro for java methods. it translates the method ;; into a lambda form that calls invoke. Which is nice because you @@ -295,33 +263,10 @@ (defun read-invoke (stream char arg) (unread-char char stream) (let ((name (read stream))) - (if (and arg (eql (abs arg) 1)) - (let ((cell (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ; work around bug that gensym here errors when compiling - (object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet - (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas))) - (proclaim `(special ,cell)) - ; (set cell nil) - `(lambda (,object-var &rest ,args-var) - (declare (optimize (speed 3) (safety 0))) - (if (boundp ',cell) ;costing me 10% here because I can't force cell to be bound and hence do null test. - (if (null ,args-var) - (jcall ,cell ,object-var) - (if (null (cdr (the cons ,args-var))) - ,(if (minusp arg) - `(jcall-static ,cell ,object-var (car (the cons ,args-var))) - `(jcall ,cell ,object-var (car (the cons ,args-var)))) - ,(if (minusp arg) - `(apply 'jcall-static ,cell ,object-var (the list ,args-var)) - `(apply 'jcall ,cell ,object-var (the list ,args-var))))) - (progn - (setq ,cell (invoke-find-method ,name ,object-var ,args-var)) - ,(if (minusp arg) - `(apply 'jcall-static ,cell ,object-var ,args-var) - `(apply 'jcall ,cell ,object-var ,args-var)))))) - (let ((object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet - (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas))) - `(lambda (,object-var &rest ,args-var) - (invoke-restargs ,name ,object-var ,args-var ,(eql arg 0))))))) + (let ((object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet + (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas))) + `(lambda (,object-var &rest ,args-var) + (invoke-restargs ,name ,object-var ,args-var ,(eql arg 0)))))) (set-dispatch-macro-character #\# #\" 'read-invoke)) (defmacro with-constant-signature (fname-jname-pairs &body body) @@ -452,7 +397,7 @@ (jmethod "java.lang.Class" "forName" "java.lang.String" "boolean" "java.lang.ClassLoader")) (defconstant +true+ - (jstatic-raw "parseBoolean" "java.lang.Boolean" "true")) + (make-immediate-object t :boolean)) (defun find-java-class (name) (or (jstatic +for-name+ "java.lang.Class" Modified: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- trunk/abcl/contrib/jss/jss.asd Sat May 21 05:40:49 2011 (r13282) +++ trunk/abcl/contrib/jss/jss.asd Sat May 21 05:41:09 2011 (r13283) @@ -1,13 +1,9 @@ ;;;; -*- Mode: LISP -*- - -;;; XXX -;;(java:add-to-classpath "~/work/lsw2/lib/jscheme.jar") - (in-package :asdf) (defsystem :jss - :author "Alan Ruttenberg" - :version "2.0" + :author "Alan Ruttenberg, Mark Evenson" + :version "2.0.0" :components ((:module base :pathname "" :serial t :components ((:file "packages") Modified: trunk/abcl/contrib/jss/packages.lisp ============================================================================== --- trunk/abcl/contrib/jss/packages.lisp Sat May 21 05:40:49 2011 (r13282) +++ trunk/abcl/contrib/jss/packages.lisp Sat May 21 05:41:09 2011 (r13283) @@ -14,8 +14,3 @@ #:get-java-field) (:shadow #:add-to-classpath)) -(eval-when (:compile-toplevel :load-toplevel) - (java:add-to-classpath - (merge-pathnames "../../../lsw2/lib/jscheme.jar" (asdf:component-pathname (asdf:find-system :jss))))) - - From mevenson at common-lisp.net Sat Jun 4 20:25:37 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:37 -0700 Subject: [armedbear-cvs] r13284 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Sat May 21 18:35:30 2011 New Revision: 13284 Log: Fix compilation from last commit if 'jscheme.jar' isn't present. Enlarge exported API with useful looking functions. Modified: trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/packages.lisp Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Sat May 21 05:41:09 2011 (r13283) +++ trunk/abcl/contrib/jss/invoke.lisp Sat May 21 18:35:30 2011 (r13284) @@ -134,34 +134,16 @@ ;; between when we call invoke and when invoke calls the actual ;; function you care about. -(defvar *max-java-method-args* 20 "Increase if you call java methods with more than 20 arguments") - -(defun argvs () - (let ((get (load-time-value (jmethod (jclass "java.lang.ThreadLocal") "get"))) - (argvs (load-time-value (jnew (jconstructor "java.lang.ThreadLocal")))) - (null (load-time-value (make-immediate-object nil :ref)))) - (let ((res (jcall-raw get argvs))) - (if (equal res null) - (let ((it (jnew-array "java.lang.Object" *max-java-method-args*))) - (dotimes (i *max-java-method-args*) - (setf (jarray-ref it i) (jnew-array "java.lang.Object" i))) - (jcall (jmethod (jclass "java.lang.ThreadLocal") "set" "java.lang.Object") - argvs it) - it) - res)))) - - (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *do-auto-imports* t)) (defvar *imports-resolved-classes* (make-hash-table :test 'equal)) - (defun find-java-class (name) (jclass (maybe-resolve-class-against-imports name))) (defmacro invoke-add-imports (&rest imports) - "push these imports onto the search path. If multiple, earlier in list take precedence" + "Push these imports onto the search path. If multiple, earlier in list take precedence" `(eval-when (:compile-toplevel :load-toplevel :execute) (clrhash *imports-resolved-classes*) (dolist (i (reverse ',imports)) @@ -182,18 +164,16 @@ (defvar *class-name-to-full-case-insensitive* (make-hash-table :test 'equalp)) -;; This is the function that calls invoke to call your java method. The first argument is the -;; method name or 'new. The second is the object you are calling it on, followed by the rest of the -;; arguments. If the "object" is a symbol, then that symbol is assumed to be a java class, and -;; a static method on the class is called, otherwise a regular method is called. +;; This is the function that calls invoke to call your java +;; method. The first argument is the method name or 'new. The second +;; is the object you are calling it on, followed by the rest of the +;; arguments. If the "object" is a symbol, then that symbol is assumed +;; to be a java class, and a static method on the class is called, +;; otherwise a regular method is called. (defun invoke (method object &rest args) (invoke-restargs method object args)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *invoke-methods* - (load-time-value (jcall (jmethod "java.lang.Class" "getMethods" ) (jclass "jsint.Invoke"))))) - (defun invoke-restargs (method object args &optional (raw? nil)) (let* ((object-as-class-name (if (symbolp object) (maybe-resolve-class-against-imports object))) @@ -209,8 +189,7 @@ (apply #'jstatic method object-as-class args) (apply #'jcall method object args)))))) -;;; Method name --> Object --> jmethod -;;; +;;; Method name as String --> String | Symbol --> jmethod (defvar *methods-cache* (make-hash-table :test #'equal)) (defun get-jmethod (method object) @@ -422,10 +401,10 @@ (cond ((file-directory-p s) ) ((equal (pathname-type s) "jar") - (jar-import (merge-pathnames (jcall "toString" s) (format nil "~a/" (jstatic "getProperty" "java.lang.System" "user.dir"))))))) - - (jcall "split" cp (string (jstatic "peekStatic" '|jsint.Invoke| (jclass "java.io.File") "pathSeparatorChar"))) - ))) + (jar-import (merge-pathnames (jcall "toString" s) + (format nil "~a/" (jstatic "getProperty" "java.lang.System" "user.dir"))))))) + (jcall "split" cp + (string (jfield (jclass "java.io.File") "pathSeparatorChar")))))) (import-class-path (jcall "getClassPath" (jstatic "getRuntimeMXBean" '|java.lang.management.ManagementFactory|))) (import-class-path (jcall "getBootClassPath" (jstatic "getRuntimeMXBean" '|java.lang.management.ManagementFactory|))) )) @@ -486,19 +465,6 @@ for i below (#"size" classesv) collect (#"getName" (#"elementAt" classesv i)))))) - -;; Modifiy this from Java.java to add a lisp defined classloader. -;; private static Class classForName(String className) throws ClassNotFoundException -;; { -;; try { -;; return Class.forName(className); -;; } -;; catch (ClassNotFoundException e) { -;; return Class.forName(className, true, JavaClassLoader.getPersistentInstance()); -;; } -;; } -;; http://www.javaworld.com/javaworld/jw-10-1996/jw-10-indepth-p2.html - (defvar *added-to-classpath* nil) (defvar *inhibit-add-to-classpath* nil) @@ -524,36 +490,12 @@ (push absolute *added-to-classpath*))))) (defun get-dynamic-class-path () - (dump-classpath) -#+nil - (map 'list (lambda(el) - (let ((path (#"toString" el))) - (if (eql (search "file:/" path) 0) - (subseq path 5) - path))) - (#"getPathComponents" (#"getClassPath" *classpath-manager*)))) - -#+nil -(eval-when (:load-toplevel :execute) - (maybe-install-bsh-classloader)) - - - -; http://java.sun.com/j2se/1.5.0/docs/api/java/lang/management/MemoryMXBean.html -; http://java.sun.com/docs/hotspot/gc/ -; http://www.javaworld.com/javaworld/jw-01-2002/jw-0111-hotspotgc-p2.html -; http://java.sun.com/docs/hotspot/VMOptions.html -; http://java.sun.com/docs/hotspot/gc5.0/gc_tuning_5.html -; http://java.sun.com/docs/hotspot/gc1.4.2/faq.html -; http://java.sun.com/developer/technicalArticles/Programming/turbo/ -;-XX:MinFreeHeapRatio= -;-XX:MaxHeapFreeRatio= -;-XX:NewRatio= -;-XX:SurvivorRatio= -;-XX:SoftRefLRUPolicyMSPerMB=10000 -;-XX:+PrintTenuringDistribution -;-XX:MaxLiveObjectEvacuationRatio - + (rest + (find-if (lambda (loader) + (string= "org.armedbear.lisp.JavaClassLoader" + (jclass-name (jobject-class loader)))) + (dump-classpath) + :key #'car))) (defun java-gc () (#"gc" (#"getRuntime" 'java.lang.runtime)) @@ -698,7 +640,7 @@ (strings) and method definitions (closures). For missing methods, a dummy implementation is provided that - calls the method on DISPATCH-TO" + calls the method on DISPATCH-TO." (let ((implemented-methods (loop for m in method-names-and-defs for i from 0 @@ -724,15 +666,3 @@ (apply #'java::%jnew-proxy interface safe-method-names-and-defs)))) -(defun java-exception-report (condition) - (if (and (typep condition 'java-exception) - (java-exception-cause condition) - (equal (jclass-name (jobject-class (java-exception-cause condition))) - "jsint.BacktraceException")) - (with-output-to-string (s) - (let ((writer (new 'stringwriter))) - (#"printStackTrace" (#"getBaseException"(java-exception-cause condition)) (new 'printwriter writer)) - (write-string (#"replaceFirst" (#"toString" writer) "(?s)\\s*at sun.reflect.*" "") s)) - ) - (#"replaceFirst" (princ-to-string condition) "(?s)\\\\s*at jsint.E.*" ""))) - Modified: trunk/abcl/contrib/jss/packages.lisp ============================================================================== --- trunk/abcl/contrib/jss/packages.lisp Sat May 21 05:41:09 2011 (r13283) +++ trunk/abcl/contrib/jss/packages.lisp Sat May 21 18:35:30 2011 (r13284) @@ -4,13 +4,28 @@ (:export #:*inhibit-add-to-classpath* #:*added-to-classpath* + #:*do-auto-imports* + + #:add-directory-jars-to-class-path #:add-to-classpath - #:new + #:find-java-class #:need-to-add-directory-jar? - #:add-directory-jars-to-class-path -;;; compatibility - #:ensure-compatiblity #:*cl-user-compatibility* - #:get-java-field) +;;; deprecated + #:new ; use JAVA:NEW + #:get-java-field ; use JAVA:JFIELD + +;;; Move to JAVA? + #:jclass-all-interfaces + +;;; Useful utilities to convert common Java items to Lisp counterparts + #:hashmap-to-hashtable + #:iterable-to-list + #:list-to-list + #:set-to-list + #:vector-to-list + +;;; Enable compatibility with jss-1.0 by placing symbols in CL-USER + #:ensure-compatiblity #:*cl-user-compatibility*) (:shadow #:add-to-classpath)) From mevenson at common-lisp.net Sat Jun 4 20:25:44 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:44 -0700 Subject: [armedbear-cvs] r13285 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Sat May 21 19:18:23 2011 New Revision: 13285 Log: ENSURE-COMPATIBILTY now imports most of the external JSS into CL-USER. Adjusted comments. Optimize INVOKE-FIND-METHOD a bit by the use of a constant DEFMETHOD. Modified: trunk/abcl/contrib/jss/compat.lisp trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/packages.lisp Modified: trunk/abcl/contrib/jss/compat.lisp ============================================================================== --- trunk/abcl/contrib/jss/compat.lisp Sat May 21 18:35:30 2011 (r13284) +++ trunk/abcl/contrib/jss/compat.lisp Sat May 21 19:18:23 2011 (r13285) @@ -5,8 +5,12 @@ (defun ensure-compatiblity () (setf *cl-user-compatibility* t) - (dolist (symbol '(get-java-field new)) - (unintern symbol :cl-user) - (import symbol :cl-user))) + (let ((dont-export '(add-to-classpath *cl-user-compatibility*))) + (loop :for symbol :being :each :external-symbol :in :jss + :when (not (find symbol dont-export)) + :do + (unintern symbol :cl-user) + :and :do + (import symbol :cl-user)))) Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Sat May 21 18:35:30 2011 (r13284) +++ trunk/abcl/contrib/jss/invoke.lisp Sat May 21 19:18:23 2011 (r13285) @@ -1,6 +1,7 @@ -;; invoke.lisp v1.0 +;; invoke.lisp v2.0 ;; ;; Copyright (C) 2005 Alan Ruttenberg +;; Copyright (C) 2011 Mark Evenson ;; ;; Since most of this code is derivative of the Jscheme System, it is ;; licensed under the same terms, namely: @@ -28,17 +29,12 @@ ;; 3. This notice may not be removed or altered from any source ;; distribution. -;; This file uses invoke.java from jscheme -;; (http://jscheme.sourceforge.net/jscheme/src/jsint/Invoke.java). -;; The easiest way to use it is to download -;; http://jscheme.sourceforge.net/jscheme/lib/jscheme.jar -;; and add it to the classpath in the file that invokes abcl. - -;; Invoke.java effectively implements dynamic dispatch of java methods. This -;; is used to make it real easy, if perhaps less efficient, to write -;; java code since you don't need to be bothered with imports, or with -;; figuring out which method to call. The only time that you need to -;; know a class name is when you want to call a static method, or a + +;; The dynamic dispatch of the java.lang.reflect package is used to +;; make it real easy, if perhaps less efficient, to write Java code +;; since you don't need to be bothered with imports, or with figuring +;; out which method to call. The only time that you need to know a +;; class name is when you want to call a static method, or a ;; constructor, and in those cases, you only need to know enough of ;; the class name that is unique wrt to the classes on your classpath. ;; @@ -51,21 +47,22 @@ ;; (#"write" sw "World") ;; (print (#"toString" sw))) -;; What's happened here? First, all the classes in all the jars in the classpath have -;; been collected. For each class a.b.C.d, we have recorded that -;; b.c.d, b.C.d, C.d, c.d, and d potentially refer to this class. In -;; your call to new, as long as the symbol can refer to only one class, we use that -;; class. In this case, it is java.io.StringWriter. You could also have written -;; (new 'io.stringwriter), (new '|io.StringWriter|), (new 'java.io.StringWriter)... +;; What's happened here? First, all the classes in all the jars in the +;; classpath have been collected. For each class a.b.C.d, we have +;; recorded that b.c.d, b.C.d, C.d, c.d, and d potentially refer to +;; this class. In your call to new, as long as the symbol can refer to +;; only one class, we use that class. In this case, it is +;; java.io.StringWriter. You could also have written (new +;; 'io.stringwriter), (new '|io.StringWriter|), (new +;; 'java.io.StringWriter)... ;; the call (#"write" sw "Hello "), uses the code in invoke.java to -;; call the method named "write" with the arguments sw and "Hello -;; ". Invoke.java figures out the right java method to call, and calls -;; it. +;; call the method named "write" with the arguments sw and "Hello ". +;; JSS figures out the right java method to call, and calls it. ;; If you want to do a raw java call, use #0"toString". Raw calls -;; return their results as java objects, avoiding doing the usual java -;; object to lisp object conversions that abcl does. +;; return their results as Java objects, avoiding doing the usual Java +;; object to Lisp object conversions that ABCL does. ;; (with-constant-signature ((name jname raw?)*) &body body) ;; binds a macro which expands to a jcall, promising that the same method @@ -87,7 +84,6 @@ ;; (jcmn class-name) lists the names of all methods for the class ;; ;; TODO -;; - Use a package other than common-lisp-user ;; - Make with-constant-signature work for static methods too. ;; - #2"toString" to work like function scoped (with-constant-signature ((tostring "toString")) ...) ;; - #3"toString" to work like runtime scoped (with-constant-signature ((tostring "toString")) ...) @@ -125,15 +121,6 @@ (in-package :jss) -;; invoke takes it's arguments in a java array. In order to not cons -;; one up each time, but to be thread safe, we allocate a static array -;; of such arrays and save them in threadlocal storage. I'm lazy and -;; so I just assume you will never call a java method with more than -;; *max-java-method-args*. Fix this if it is a problem for you. We -;; don't need to worry about reentrancy as the array is used only -;; between when we call invoke and when invoke calls the actual -;; function you care about. - (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *do-auto-imports* t)) @@ -189,6 +176,8 @@ (apply #'jstatic method object-as-class args) (apply #'jcall method object args)))))) +(defconstant +true+ (make-immediate-object t :boolean)) + ;;; Method name as String --> String | Symbol --> jmethod (defvar *methods-cache* (make-hash-table :test #'equal)) @@ -207,10 +196,11 @@ (gethash method *methods-cache*)) jmethod)) -(defparameter *last-invoke-find-method-args* nil) +(defconstant +set-accessible+ + (jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean")) + ;;; TODO optimize me! (defun invoke-find-method (method object args) - (setf *last-invoke-find-method-args* (list method object args)) (let ((jmethod (get-jmethod method object))) (unless jmethod (setf jmethod @@ -221,7 +211,7 @@ ;;; instance method (apply #'jresolve-method method object args))) - (jcall "setAccessible" jmethod +true+) + (jcall +set-accessible+ jmethod +true+) (set-jmethod method object jmethod)) jmethod)) @@ -231,7 +221,7 @@ ;; macro takes one arg. If 0, then jstatic-raw is called, so that abcl doesn't ;; automagically convert the returned java object into a lisp object. So ;; #0"toString" returns a java.lang.String object, where as #"toString" returns -;; a regular lisp string as abcl converts the java string to a lisp string. +;; a regular Lisp string as ABCL converts the Java string to a Lisp string. (eval-when (:compile-toplevel :load-toplevel :execute) @@ -375,9 +365,6 @@ (defconstant +for-name+ (jmethod "java.lang.Class" "forName" "java.lang.String" "boolean" "java.lang.ClassLoader")) -(defconstant +true+ - (make-immediate-object t :boolean)) - (defun find-java-class (name) (or (jstatic +for-name+ "java.lang.Class" (maybe-resolve-class-against-imports name) +true+ java::*classloader*) Modified: trunk/abcl/contrib/jss/packages.lisp ============================================================================== --- trunk/abcl/contrib/jss/packages.lisp Sat May 21 18:35:30 2011 (r13284) +++ trunk/abcl/contrib/jss/packages.lisp Sat May 21 19:18:23 2011 (r13285) @@ -6,6 +6,10 @@ #:*added-to-classpath* #:*do-auto-imports* + #:invoke-restargs + #:with-constant-signature + + #:invoke-add-imports #:add-directory-jars-to-class-path #:add-to-classpath #:find-java-class From mevenson at common-lisp.net Sat Jun 4 20:25:48 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:48 -0700 Subject: [armedbear-cvs] r13286 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Sat May 21 19:18:43 2011 New Revision: 13286 Log: Fix GET-JAVA-FIELD. Remove unncessary (?) private GENSYM mechanism in INVOKE-RESTARGS for SYMBOL-MACROLET bug in abcl-0.18, which has a) been fixed with abcl-0.18.1, and b) is no longer using SYMBOL-MACROLET here. Modified: trunk/abcl/contrib/jss/invoke.lisp Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Sat May 21 19:18:23 2011 (r13285) +++ trunk/abcl/contrib/jss/invoke.lisp Sat May 21 19:18:43 2011 (r13286) @@ -223,17 +223,12 @@ ;; #0"toString" returns a java.lang.String object, where as #"toString" returns ;; a regular Lisp string as ABCL converts the Java string to a Lisp string. - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage lambdas (:use)) - (defvar *lcount* 0)) - (eval-when (:compile-toplevel :load-toplevel :execute) (defun read-invoke (stream char arg) (unread-char char stream) (let ((name (read stream))) - (let ((object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet - (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas))) + (let ((object-var (gensym)) + (args-var (gensym))) `(lambda (,object-var &rest ,args-var) (invoke-restargs ,name ,object-var ,args-var ,(eql arg 0)))))) (set-dispatch-macro-character #\# #\" 'read-invoke)) @@ -331,18 +326,19 @@ (if try-harder (let* ((class (if (symbolp object) (setq object (find-java-class object)) - (if (equal "java.lang.Class" (jclass-name (jobject-class object)) ) - object - (jobject-class object)))) + (if (equal "java.lang.Class" (jclass-name (jobject-class object))) + object + (jobject-class object)))) (jfield (if (java-object-p field) field - (find field (#"getDeclaredFields" class) :key 'jfield-name :test 'equal)))) + (find field (#"getDeclaredFields" class) + :key 'jfield-name :test 'equal)))) (#"setAccessible" jfield t) (values (#"get" jfield object) jfield)) - (if (symbolp object) - (let ((class (find-java-class object))) - (jfield class field) - (jfield field object))))) + (if (symbolp object) + (let ((class (find-java-class object))) + (jfield class field)) + (jfield field object)))) ;; use #"getSuperclass" and #"getInterfaces" to see whether there are fields in superclasses that we might set (defun set-java-field (object field value &optional (try-harder *running-in-osgi*)) From vvoutilainen at common-lisp.net Sat Jun 4 20:25:54 2011 From: vvoutilainen at common-lisp.net (vvoutilainen at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:54 -0700 Subject: [armedbear-cvs] r13287 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Mon May 23 08:46:06 2011 New Revision: 13287 Log: Copy version from defaults if not explicitly provided. 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 Sat May 21 19:18:43 2011 (r13286) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Mon May 23 08:46:06 2011 (r13287) @@ -1254,6 +1254,7 @@ boolean nameSupplied = false; boolean typeSupplied = false; boolean directorySupplied = false; + boolean versionSupplied = false; for (int i = 0; i < args.length; i += 2) { LispObject key = args[i]; LispObject value = args[i + 1]; @@ -1290,6 +1291,7 @@ typeSupplied = true; } else if (key == Keyword.VERSION) { version = value; + versionSupplied = true; } else if (key == Keyword.DEFAULTS) { defaults = coerceToPathname(value); } else if (key == Keyword.CASE) { @@ -1312,6 +1314,9 @@ if (!typeSupplied) { type = defaults.type; } + if (!versionSupplied) { + version = defaults.version; + } } final Pathname p; final boolean logical; From vvoutilainen at common-lisp.net Sat Jun 4 20:25:59 2011 From: vvoutilainen at common-lisp.net (vvoutilainen at common-lisp.net) Date: Sat, 04 Jun 2011 13:25:59 -0700 Subject: [armedbear-cvs] r13288 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Mon May 23 09:27:17 2011 New Revision: 13288 Log: Revert the earlier attempt to fix the version copying issue, it badly breaks quicklisp. 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 Mon May 23 08:46:06 2011 (r13287) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Mon May 23 09:27:17 2011 (r13288) @@ -1254,7 +1254,6 @@ boolean nameSupplied = false; boolean typeSupplied = false; boolean directorySupplied = false; - boolean versionSupplied = false; for (int i = 0; i < args.length; i += 2) { LispObject key = args[i]; LispObject value = args[i + 1]; @@ -1291,7 +1290,6 @@ typeSupplied = true; } else if (key == Keyword.VERSION) { version = value; - versionSupplied = true; } else if (key == Keyword.DEFAULTS) { defaults = coerceToPathname(value); } else if (key == Keyword.CASE) { @@ -1314,9 +1312,6 @@ if (!typeSupplied) { type = defaults.type; } - if (!versionSupplied) { - version = defaults.version; - } } final Pathname p; final boolean logical; From mevenson at common-lisp.net Sat Jun 4 20:26:04 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:26:04 -0700 Subject: [armedbear-cvs] r13289 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue May 24 02:01:03 2011 New Revision: 13289 Log: Fix ENSURE-DIRECTORIES-EXIST by loosening wild pathname restrictions. CLHS: Function ENSURE-DIRECTORIES-EXIST "An error of type file-error is signaled if the host, device, or directory part of pathspec is wild." Modified: trunk/abcl/src/org/armedbear/lisp/ensure-directories-exist.lisp Modified: trunk/abcl/src/org/armedbear/lisp/ensure-directories-exist.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ensure-directories-exist.lisp Mon May 23 09:27:17 2011 (r13288) +++ trunk/abcl/src/org/armedbear/lisp/ensure-directories-exist.lisp Tue May 24 02:01:03 2011 (r13289) @@ -36,9 +36,14 @@ (defun ensure-directories-exist (pathspec &key verbose) (let ((pathname (pathname pathspec)) (created-p nil)) - (when (wild-pathname-p pathname) +;;; CLHS: Function ENSURE-DIRECTORIES-EXIST "An error of type +;;; file-error is signaled if the host, device, or directory part of +;;; pathspec is wild." + (when (or (wild-pathname-p pathname :host) + (wild-pathname-p pathname :device) + (wild-pathname-p pathname :directory)) (error 'file-error - :format-control "Bad place for a wild pathname." + :format-control "Bad place for a wild HOST, DEVICE, or DIRECTORY component." :pathname pathname)) (let ((dir (pathname-directory pathname))) (loop for i from 1 upto (length dir) From mevenson at common-lisp.net Sat Jun 4 20:26:11 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:26:11 -0700 Subject: [armedbear-cvs] r13290 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue May 24 05:24:46 2011 New Revision: 13290 Log: Strip VERSION from the source location output by COMPILE-FILE. ABCL currently outputs non-readable--by the Lisp reader--namestrings for any PATHNAME with a non-NIL VERSION. With the recent fixes to how ABCL deals with VERSION components by defaulting to the ANSI specified :NEWEST in MERGE-PATHNAMES, this breaks ASDF compiliation which tends to acculumlate such PATHNAMES in its labryinth of cross-implementation TRUENAMIZE* and LISPIZE-PATHNAME invocations. Since VERSION doesn't really have an effect on the filesystems that ABCL deals with we just silently nip it to NIL before forming our FASL source location. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Tue May 24 02:01:03 2011 (r13289) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Tue May 24 05:24:46 2011 (r13290) @@ -536,7 +536,8 @@ (failure-p nil)) (with-open-file (in input-file :direction :input) (let* ((*compile-file-pathname* (pathname in)) - (*compile-file-truename* (truename in)) + (*compile-file-truename* (make-pathname :defaults (truename in) + :version nil)) (*source* *compile-file-truename*) (*class-number* 0) (namestring (namestring *compile-file-truename*)) From mevenson at common-lisp.net Sat Jun 4 20:26:14 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:26:14 -0700 Subject: [armedbear-cvs] r13291 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue May 24 05:25:05 2011 New Revision: 13291 Log: Reimplement the logic MERGE-PATHNAMES for Pathname version. I started from scratch interpreting these two passages from the CLHS Function MERGE-PATHNAMES entry: "If no version is supplied, default-version is used. If default-version is nil, the version component will remain unchanged." "If pathname does not specify a name, then the version, if not provided, will come from default-pathname, just like the other components. If pathname does specify a name, then the version is not affected by default-pathname. If this process leaves the version missing, the default-version is used." The previous logic was certainly not obeying the rule where if the default-version was nil. Redoing the logic to paraphase the specification seemed simpler than trying to drawing the corresponding logic tree and laboriously checking all the cases. 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 Tue May 24 05:24:46 2011 (r13290) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Tue May 24 05:25:05 2011 (r13291) @@ -1876,15 +1876,32 @@ } else { result.type = d.type; } - if (pathname.version != NIL) { - result.version = pathname.version; - } else if (pathname.name instanceof AbstractString) { + // CLHS Function MERGE-PATHNAMES + // "If no version is supplied, default-version is used. If + // default-version is nil, the version component will remain + // unchanged." + if (p.version == NIL && defaultVersion != NIL) { result.version = defaultVersion; - } else if (defaultPathname.version != NIL) { + } else if (p.version == NIL && defaultVersion == NIL) { + result.version = p.version; + // "If pathname does not specify a name, then the version, if + // not provided, will come from default-pathname, just like + // the other components. If pathname does specify a name, + // then the version is not affected by default-pathname. If + // this process leaves the version missing, the + // default-version is used." + } else if (p.name == NIL && p.version == NIL) { result.version = defaultPathname.version; + } else if (p.name != NIL) { + if (defaultVersion != NIL) { + result.version = defaultVersion; + } else { + result.version = p.version; + } } else { - result.version = defaultVersion; + result.version = defaultPathname.version; } + if (pathname instanceof LogicalPathname) { // When we're returning a logical result.device = Keyword.UNSPECIFIC; From mevenson at common-lisp.net Sat Jun 4 20:26:18 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:26:18 -0700 Subject: [armedbear-cvs] r13292 - trunk/abcl Message-ID: Author: mevenson Date: Tue May 24 05:25:23 2011 New Revision: 13292 Log: Untabify. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Tue May 24 05:25:05 2011 (r13291) +++ trunk/abcl/build.xml Tue May 24 05:25:23 2011 (r13292) @@ -1,10 +1,10 @@ + name="abcl-master" default="abcl.wrapper" basedir="."> Compiling, testing, and packaging Armed Bear Common Lisp - + Main Ant targets: @@ -31,17 +31,17 @@ + value="${basedir}/build"/> + value="${build.dir}/classes"/> + value="${basedir}/src"/> + value="${basedir}/dist"/> + value="${dist.dir}/abcl.jar"/> + value="${basedir}/ext"/> @@ -53,7 +53,7 @@ + classname="javax.script.ScriptEngine"/> @@ -112,81 +112,81 @@ - + - + + value="abcl-test-${build.stamp}.log"/> + value="${java.home}/bin/java"/> - - - - + + + + - + + property="abcl.lisp.p"/> java.version: ${java.version} - - - - + + + + + depends="abcl.init" + unless="abcl.java.version.p"> WARNING: Use of Java version ${java.version} not recommended. - + + depends="abcl.init" + unless="abcl.jsr-223.p"> - Notice: JSR-223 support won't be built since it is not - supported, neither natively by your JVM nor by - libraries in the CLASSPATH. + Notice: JSR-223 support won't be built since it is not + supported, neither natively by your JVM nor by + libraries in the CLASSPATH. + depends="abcl.init,abcl.java.warning,abcl.jsr-223.notice"> - - + failonerror="true"> + + + file="${build.classes.dir}/org/armedbear/lisp/build"/> - + - + @@ -206,16 +206,16 @@ - - - - + + + + - + + depends="abcl.copy.lisp,abcl.compile.java,abcl.system.update.maybe,abcl.fasls.uptodate" + unless="abcl.fasls.uptodate.p"> Compiling Lisp system from ${abcl.home.dir} @@ -238,12 +238,12 @@ + classname="org.armedbear.lisp.Main"> - + @@ -254,7 +254,7 @@ + value="${build.classes.dir}/org/armedbear/lisp/build"/> @@ -324,7 +324,7 @@ + value="${build.classes.dir}/org/armedbear/lisp/version"/> @@ -348,9 +348,9 @@ depends="abcl.compile.java" unless="abcl.stamp.version.uptodate.p"> @@ -402,55 +402,55 @@ + unless="abcl.jar.uptodate.p"> - - - -
- - - -
- - - - + compress="true" + basedir="${build.classes.dir}"> + + + +
+ + + +
+ + + + + depends="abcl.jar,abcl.wrapper.unix,abcl.wrapper.windows"> - Creates in-place exectuable shell wrapper in '${abcl.wrapper.file}' + Creates in-place exectuable shell wrapper in '${abcl.wrapper.file}' - - + + - - - - - + + + + + @@ -471,7 +471,7 @@ @@ -508,10 +508,10 @@ Invoke ABCL with JPDA listener on port 6789 - + classpathref="abcl.classpath.dist" + classname="org.armedbear.lisp.Main"> + JPDA listening on localhost:6789 @@ -519,10 +519,10 @@ Invoke ABCL with JPDA listener on port 6789 - + classpathref="abcl.classpath.build" + classname="org.armedbear.lisp.Main"> + JPDA listening on localhost:6789 @@ -530,8 +530,8 @@ + classpathref="abcl.classpath.dist" + classname="org.armedbear.lisp.Main"> @@ -544,7 +544,7 @@ + toFile="${dist.dir}/abcl-${abcl.version}.jar"/> @@ -557,17 +557,17 @@ - - - - - - + + + + + + + description="Additional includes in the source distributions relative to basedir"> @@ -605,7 +605,7 @@ + value="${build.dir}/abcl-src-${abcl.version}"/> @@ -658,10 +658,10 @@ - - - + compression="gzip"> + + + @@ -687,8 +687,8 @@ - + compress="true"> + @@ -786,10 +786,10 @@ + value="${build.dir}/classes-test"/> + value="${basedir}/test/src"/> ~A begins.~%" message) (format t "Invoking ABCL hosted on ~A ~A.~%" (software-type) (software-version)) - ;; 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) - (error - (format nil - "Failed to find the GCL ANSI tests in '~A'. -Because ~A. -To resolve, please locally obtain ~A, -and set the value of *ANSI-TESTS-DIRECTORY* to that location." - ansi-tests-directory e - *ansi-tests-master-source-location*)))))) + (format t "<--- ~A ends.~%" message)))) + +(defun verify-ansi-tests () + (unless + (probe-file *ansi-tests-directory*) + (error 'file-error + "Failed to find the GCL ANSI tests in '~A'. Please +locally obtain ~A, and set the value of *ANSI-TESTS-DIRECTORY* to that +location." + *ansi-tests-directory* + *ansi-tests-master-source-location*))) + +(defvar *ansi-tests-loaded-p* nil) +(defun load-tests () + "Load the ANSI tests but do not execute them." + (verify-ansi-tests) + (let ((*default-pathname-defaults* *ansi-tests-directory*) + (package *package*)) + (setf *package* (find-package :cl-user)) + (load "gclload1.lsp") + (load "gclload2.lsp") + (setf *package* package)) + (setf *ansi-tests-loaded-p* t)) + +(defun clean-tests () + "Do what 'make clean' would do from the GCL ANSI tests," + ;; so we don't have to hunt for 'make' in the PATH on win32. + (verify-ansi-tests) + + (mapcar #'delete-file + (append (directory (format nil "~A/*.cls" *ansi-tests-directory*)) + (directory (format nil "~A/*.abcl" *ansi-tests-directory*)) + (directory (format nil "~A/scratch/*" *ansi-tests-directory*)) + (mapcar (lambda(x) + (format nil "~A/~A" *ansi-tests-directory* 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"))))) From mevenson at common-lisp.net Sat Jun 4 20:26:44 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:26:44 -0700 Subject: [armedbear-cvs] r13298 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed May 25 07:32:16 2011 New Revision: 13298 Log: Include the CLtLv2 passages MERGE-PATHNAME for version is interpreting. 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 Wed May 25 07:32:07 2011 (r13297) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Wed May 25 07:32:16 2011 (r13298) @@ -1882,16 +1882,23 @@ } else { result.type = d.type; } - // CLHS Function MERGE-PATHNAMES - // "If no version is supplied, default-version is used. If - // default-version is nil, the version component will remain - // unchanged." - // "If pathname does not specify a name, then the version, if - // not provided, will come from default-pathname, just like - // the other components. If pathname does specify a name, - // then the version is not affected by default-pathname. If - // this process leaves the version missing, the - // default-version is used." + // CLtLv2 MERGE-PATHNAMES + + // "[T]he missing components in the given pathname are filled + // in from the defaults pathname, except that if no version is + // specified the default version is used." + + // "The merging rules for the version are more complicated and + // depend on whether the pathname specifies a name. If the + // pathname doesn't specify a name, then the version, if not + // provided, will come from the defaults, just like the other + // components. However, if the pathname does specify a name, + // then the version is not affected by the defaults. The + // reason is that the version ``belongs to'' some other file + // name and is unlikely to have anything to do with the new + // one. Finally, if this process leaves the + // version missing, the default version is used." + if (p.version != NIL) { result.version = p.version; } else if (p.name == NIL) { From mevenson at common-lisp.net Sat Jun 4 20:26:51 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:26:51 -0700 Subject: [armedbear-cvs] r13299 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 26 22:46:28 2011 New Revision: 13299 Log: Produce FILE-ERROR when a 'file' schema URL-PATHNAME has no path component. Found and patched by Matthew Daniel. 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 Wed May 25 07:32:16 2011 (r13298) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Thu May 26 22:46:28 2011 (r13299) @@ -356,8 +356,12 @@ + "'" + url.toString() + "'" + ": " + ex.toString())); } - File file = new File(uri.getPath()); - Pathname p = new Pathname(file.getPath()); + final String uriPath = uri.getPath(); + if (null == uriPath) { + error(new FileError("The URI has no path: " + uri)); + } + final File file = new File(uriPath); + final Pathname p = new Pathname(file.getPath()); this.host = p.host; this.device = p.device; this.directory = p.directory; @@ -371,7 +375,7 @@ try { uri = url.toURI().normalize(); } catch (URISyntaxException e) { - error(new LispError("Could form URI from " + error(new LispError("Couldn't form URI from " + "'" + url + "'" + " because: " + e)); } From mevenson at common-lisp.net Sat Jun 4 20:26:56 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:26:56 -0700 Subject: [armedbear-cvs] r13300 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri May 27 06:06:08 2011 New Revision: 13300 Log: TRANSLATE-PATHNAME uses source version if to version if :wild or nil. This aligns the behavior to what SBCL does. The original behavior of ABCL of using the from version would result in a lot of the usages of TRANSLATE-PATHNAME with wildcards to produce a wild version in the result which is probably never the intention. Modified: trunk/abcl/src/org/armedbear/lisp/pathnames.lisp Modified: trunk/abcl/src/org/armedbear/lisp/pathnames.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/pathnames.lisp Thu May 26 22:46:28 2011 (r13299) +++ trunk/abcl/src/org/armedbear/lisp/pathnames.lisp Fri May 27 06:06:08 2011 (r13300) @@ -323,8 +323,9 @@ (pathname-type to) case) :version (if (null (pathname-host from)) - (if (eq (pathname-version to) :wild) - (pathname-version from) + (if (or (eq (pathname-version to) :wild) + (eq (pathname-version to) nil)) + (pathname-version source) (pathname-version to)) (translate-component (pathname-version source) (pathname-version from) From mevenson at common-lisp.net Sat Jun 4 20:27:00 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:27:00 -0700 Subject: [armedbear-cvs] r13301 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri May 27 06:06:17 2011 New Revision: 13301 Log: Explicitly error from OPEN with a wild pathname. This behavior was implicit in the various PROBE-FILE calls used by OPEN to check if a pathname exists, but these wouldn't necessarily be called in all permutations of the arguments. Modified: trunk/abcl/src/org/armedbear/lisp/open.lisp Modified: trunk/abcl/src/org/armedbear/lisp/open.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/open.lisp Fri May 27 06:06:08 2011 (r13300) +++ trunk/abcl/src/org/armedbear/lisp/open.lisp Fri May 27 06:06:17 2011 (r13301) @@ -118,6 +118,10 @@ (namestring (namestring (if (typep pathname 'logical-pathname) (translate-logical-pathname pathname) pathname)))) + (when (wild-pathname-p pathname) + (error 'file-error + :pathname pathname + :format-control "Bad place for a wild pathname.")) (when (memq direction '(:output :io)) (unless if-exists-given (setf if-exists From mevenson at common-lisp.net Sat Jun 4 20:27:06 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:27:06 -0700 Subject: [armedbear-cvs] r13302 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri May 27 06:06:26 2011 New Revision: 13302 Log: Include the version in the internal PATHNAME copy contructor. With this change, MERGE-PATHNAMES should now follow ANSI for version arguments, finally closing ticket #150. 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 Fri May 27 06:06:17 2011 (r13301) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Fri May 27 06:06:26 2011 (r13302) @@ -168,6 +168,15 @@ Debug.assertTrue(false); } } + if (p.version != NIL) { + if (p.version instanceof Symbol) { + version = p.version; + } else if (p.version instanceof LispInteger) { + version = p.version; + } else { + Debug.assertTrue(false); + } + } } public Pathname(String s) { From mevenson at common-lisp.net Sat Jun 4 20:27:11 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:27:11 -0700 Subject: [armedbear-cvs] r13303 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri May 27 07:13:18 2011 New Revision: 13303 Log: Automagically find contrib via (REQUIRE :ABCL-CONTRIB). REQUIREing :ABCL-CONTRIB will look for a 'abcl-contrib.jar' in the same directory as 'abcl.jar'. If found, all the ASDF definitions one level deep will be added to the ASDF search path, allowing contribs to be loaded via REQUIRE or ASDF:LOAD-SYSTEM. No longer compile contribs as ASDF will do this for us. Since we moved to ASDF2, the contrib FASLs have been compiled but not packaged, so this doesn't change any behavior except making packaging shorter. When we figure out how to package FASLs with ASDF systems in jar files, we will revisit this topic. Added: trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Modified: trunk/abcl/build.xml trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/require.lisp Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Fri May 27 06:06:26 2011 (r13302) +++ trunk/abcl/build.xml Fri May 27 07:13:18 2011 (r13303) @@ -469,40 +469,30 @@ - - - - - - - - + - Packaged contribs in ${dist.dir}/abcl-contrib.jar. -To use ASDF-INSTALL, use the following in your ~/.abclrc: +To use contribs, ensure that 'abcl-contrib.jar' is in the same +directory as 'abcl.jar', then + + CL-USER> (require 'abcl-contrib) - (require 'asdf) - (pushnew "jar:file:${dist.dir}/abcl-contrib.jar!/asdf-install/" asdf:*central-registry*) +will place all the contribs in the ASDF registry path. -Then issuing +To load a contrib, something like - CL-USER> (require 'asdf-install) + CL-USER> (require 'jss) -will load ASDF-INSTALL. +will compile (if necessary) and load JSS. Added: trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Fri May 27 07:13:18 2011 (r13303) @@ -0,0 +1,53 @@ +(in-package :system) + +(require :asdf) + +;;; XXX make less sensitive to ABCL jar being called "abcl.jar" +;;; allow being called "abcl-x.y.z.jar for semantic versioning +;;; allow customization in system.lisp +(defun find-system-jar () + (dolist (loader (java:dump-classpath)) + (let ((abcl-jar + (find-if (lambda (p) (and (equal (pathname-name p) "abcl") + (equal (pathname-type p) "jar"))) + (rest loader)))) + (when abcl-jar + (return abcl-jar))))) + +(defvar *abcl-jar* nil + "Pathname of the jar that ABCL was loaded from. +Initialized via SYSTEM::FIND-SYSTEM-JAR.") + +(defvar *abcl-contrib* nil + "Pathname of the ABCL contrib. +Initialized via SYSTEM:FIND-CONTRIB") + +(defun find-contrib (&optional (verbose nil)) +"Attempt to find the ABCL contrib jar and add its contents to ASDF." + (unless *abcl-contrib* + (unless *abcl-jar* + (setf *abcl-jar* (find-system-jar))) + (when *abcl-jar* + (let ((abcl-contrib (make-pathname :defaults *abcl-jar* + :name "abcl-contrib"))) + (when (probe-file abcl-contrib) + (setf *abcl-contrib* abcl-contrib) + (dolist (asdf-file + (directory (make-pathname :device (list *abcl-contrib*) + :directory '(:absolute :wild) + :name :wild + :type "asd"))) + (let ((asdf-directory + (make-pathname :defaults asdf-file :name nil :type nil))) + (when verbose + (format t "Adding ~A to ASDF.~%" asdf-directory)) + (push asdf-directory asdf:*central-registry*))) + *abcl-contrib*))))) + +(when (find-contrib) + (provide :abcl-contrib)) + + + + + Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri May 27 06:06:26 2011 (r13302) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri May 27 07:13:18 2011 (r13303) @@ -126,7 +126,8 @@ (load (do-compile "destructuring-bind.lisp")) (load (do-compile "asdf.lisp")) ;; But not for these. - (mapc #'do-compile '("adjoin.lisp" + (mapc #'do-compile '("abcl-contrib.lisp" + "adjoin.lisp" "and.lisp" "apropos.lisp" "arrays.lisp" Modified: trunk/abcl/src/org/armedbear/lisp/require.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/require.lisp Fri May 27 06:06:26 2011 (r13302) +++ trunk/abcl/src/org/armedbear/lisp/require.lisp Fri May 27 07:13:18 2011 (r13303) @@ -47,6 +47,7 @@ (format *error-output* "Failed to require ~A because '~A'~%" module e)) nil)))) + (defvar *module-provider-functions* nil) From mevenson at common-lisp.net Sat Jun 4 20:27:15 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:27:15 -0700 Subject: [armedbear-cvs] r13304 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri May 27 07:13:27 2011 New Revision: 13304 Log: Untabify. Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri May 27 07:13:18 2011 (r13303) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri May 27 07:13:27 2011 (r13304) @@ -127,7 +127,7 @@ (load (do-compile "asdf.lisp")) ;; But not for these. (mapc #'do-compile '("abcl-contrib.lisp" - "adjoin.lisp" + "adjoin.lisp" "and.lisp" "apropos.lisp" "arrays.lisp" @@ -176,14 +176,14 @@ "enough-namestring.lisp" "ensure-directories-exist.lisp" "error.lisp" - "extensible-sequences.lisp" + "extensible-sequences.lisp" "featurep.lisp" "fdefinition.lisp" "fill.lisp" "find-all-symbols.lisp" "gentemp.lisp" "gray-streams.lisp" - "gui.lisp" + "gui.lisp" "inline.lisp" "inspect.lisp" ;;"j.lisp" From ehuelsmann at common-lisp.net Sat Jun 4 20:27:20 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 04 Jun 2011 13:27:20 -0700 Subject: [armedbear-cvs] r13305 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 27 15:38:25 2011 New Revision: 13305 Log: Remove PRINT-OBJECT method which masked java-side-implemented printing of built-in ERRORs. Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print-object.lisp Fri May 27 07:13:27 2011 (r13304) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Fri May 27 15:38:25 2011 (r13305) @@ -39,16 +39,12 @@ (defgeneric print-object (object stream)) (defmethod print-object ((object t) stream) - (print-unreadable-object (object stream :type t :identity t))) + (print-unreadable-object (object stream :type t :identity t) + (write-string (%write-to-string object) stream))) (defmethod print-object ((object structure-object) stream) (write-string (%write-to-string object) stream)) -(defmethod print-object ((object standard-object) stream) - (print-unreadable-object (object stream :identity t) - (format stream "~S" (class-name (class-of object)))) - object) - (defmethod print-object ((class class) stream) (print-unreadable-object (class stream :identity t) (format stream "~S ~S" From mevenson at common-lisp.net Sat Jun 4 20:27:24 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:27:24 -0700 Subject: [armedbear-cvs] r13306 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon May 30 06:40:19 2011 New Revision: 13306 Log: Fix #144 via correcly naming hints for compiler properties. Modified: trunk/abcl/src/org/armedbear/lisp/dotimes.lisp Modified: trunk/abcl/src/org/armedbear/lisp/dotimes.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/dotimes.lisp Fri May 27 15:38:25 2011 (r13305) +++ trunk/abcl/src/org/armedbear/lisp/dotimes.lisp Mon May 30 06:40:19 2011 (r13306) @@ -54,9 +54,9 @@ (let ((limit (gensym "LIMIT-"))) ;; Annotations for the compiler. (setf (get limit 'dotimes-limit-variable-p) t) - (setf (get limit 'dotimes-index-variable-name) index) + (setf (get index 'dotimes-index-variable-name) index) (setf (get index 'dotimes-index-variable-p) t) - (setf (get index 'dotimes-limit-variable-name) limit) + (setf (get limit 'dotimes-limit-variable-name) limit) `(block nil (let ((,var 0) (,limit ,count) From mevenson at common-lisp.net Sat Jun 4 20:27:27 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:27:27 -0700 Subject: [armedbear-cvs] r13307 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon May 30 08:12:02 2011 New Revision: 13307 Log: SYSTEM:ZIP now preserves last modified times. Refactored common logic between two variants into auxillary methods. Modified: trunk/abcl/src/org/armedbear/lisp/zip.java Modified: trunk/abcl/src/org/armedbear/lisp/zip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/zip.java Mon May 30 06:40:19 2011 (r13306) +++ trunk/abcl/src/org/armedbear/lisp/zip.java Mon May 30 08:12:02 2011 (r13307) @@ -36,6 +36,7 @@ import static org.armedbear.lisp.Lisp.*; import java.io.File; +import java.io.FileNotFoundException; import java.io.FileInputStream; import java.io.FileOutputStream; import java.io.IOException; @@ -83,14 +84,7 @@ pathname.writeToString())); } File file = new File(namestring); - FileInputStream in = new FileInputStream(file); - ZipEntry entry = new ZipEntry(file.getName()); - out.putNextEntry(entry); - int n; - while ((n = in.read(buffer)) > 0) - out.write(buffer, 0, n); - out.closeEntry(); - in.close(); + makeEntry(out, file); list = list.cdr(); } out.close(); @@ -105,7 +99,6 @@ public LispObject execute(LispObject first, LispObject second, LispObject third) { Pathname zipfilePathname = coerceToPathname(first); - byte[] buffer = new byte[4096]; try { String zipfileNamestring = zipfilePathname.getNamestring(); if (zipfileNamestring == null) @@ -151,14 +144,7 @@ list = list.cdr(); continue; } - FileInputStream in = new FileInputStream(file); - ZipEntry entry = new ZipEntry(directory + file.getName()); - out.putNextEntry(entry); - int n; - while ((n = in.read(buffer)) > 0) - out.write(buffer, 0, n); - out.closeEntry(); - in.close(); + makeEntry(out, file, directory + file.getName()); list = list.cdr(); } out.close(); @@ -169,6 +155,30 @@ return zipfilePathname; } - private static final Primitive zip = new zip(); + + private void makeEntry(ZipOutputStream zip, File file) + throws FileNotFoundException, IOException + { + makeEntry(zip, file, file.getName()); + } + + private void makeEntry(ZipOutputStream zip, File file, String name) + throws FileNotFoundException, IOException + { + byte[] buffer = new byte[4096]; + long lastModified = file.lastModified(); + FileInputStream in = new FileInputStream(file); + ZipEntry entry = new ZipEntry(name); + if (lastModified > 0) { + entry.setTime(lastModified); + } + zip.putNextEntry(entry); + int n; + while ((n = in.read(buffer)) > 0) + zip.write(buffer, 0, n); + zip.closeEntry(); + in.close(); + } + } From mevenson at common-lisp.net Sat Jun 4 20:27:31 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 13:27:31 -0700 Subject: [armedbear-cvs] r13308 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Mon May 30 08:56:46 2011 New Revision: 13308 Log: Implementation of a utility to package ASDF systems in jars. The recursive dependencies are just recorded, not packaged. Added: trunk/abcl/contrib/asdf-jar/ trunk/abcl/contrib/asdf-jar/asdf-jar.asd trunk/abcl/contrib/asdf-jar/asdf-jar.lisp trunk/abcl/contrib/asdf-jar/test.lisp Added: trunk/abcl/contrib/asdf-jar/asdf-jar.asd ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.asd Mon May 30 08:56:46 2011 (r13308) @@ -0,0 +1,9 @@ +;;;; -*- Mode: LISP -*- +(in-package :Asdf) + +(defsystem :asdf-jar + :author "Mark Evenson" + :version "0.1.0" + :components + ((:module base :pathname "" :components + ((:file "asdf-jar"))))) \ No newline at end of file Added: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Mon May 30 08:56:46 2011 (r13308) @@ -0,0 +1,35 @@ +(defpackage :asdf-jar + (:use :cl) + (:export #:package)) + +(in-package :asdf-jar) + +(defvar *systems*) +(defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system)) + (push c *systems*)) + +(defun package (system-name &key (recursive t) (verbose t)) + (declare (ignore recursive)) + (asdf:disable-output-translations) + (let* ((system (asdf:find-system system-name)) + (name (slot-value system 'asdf::name))) + (when verbose + (format verbose "Packaging ASDF definition of~A~%" system)) + (setf *systems* nil) + (asdf:compile-system system :force t) + (let* ((dir (asdf:component-pathname system)) + (wild-contents (merge-pathnames "**/*" dir)) + (contents (directory wild-contents)) + (output (format nil "/var/tmp/~A.jar" name)) + (topdir (truename (merge-pathnames "../" dir)))) + (when verbose + (format verbose "Packaging contents in ~A.~%" output)) + (system:zip output contents topdir))) + (asdf:initialize-output-translations)) + + + + + + + Added: trunk/abcl/contrib/asdf-jar/test.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/asdf-jar/test.lisp Mon May 30 08:56:46 2011 (r13308) @@ -0,0 +1,14 @@ +(defun init-test () + (require :quicklisp) + (ql:quickload :cl-ppcre)) + +(defun package-test () + (package :cl-ppcre)) + +(defun load-test () + (push "jar:file:/var/tmp/cl-ppcre.jar!/cl-ppcre-2.0.3/" + asdf:*central-registry*) + (asdf:disable-output-translations) + (setf asdf::*verbose-out* t) + (asdf:load-system :cl-ppcre)) + From mevenson at common-lisp.net Sat Jun 4 21:25:20 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 04 Jun 2011 14:25:20 -0700 Subject: [armedbear-cvs] r13294 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Tue May 24 05:25:55 2011 New Revision: 13294 Log: Fix #150: MAKE-PATHNAME ignores version in :DEFAULTS. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/test/lisp/abcl/pathname-tests.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java Tue May 24 05:25:39 2011 (r13293) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Tue May 24 05:25:55 2011 (r13294) @@ -1254,6 +1254,7 @@ boolean nameSupplied = false; boolean typeSupplied = false; boolean directorySupplied = false; + boolean versionSupplied = false; for (int i = 0; i < args.length; i += 2) { LispObject key = args[i]; LispObject value = args[i + 1]; @@ -1290,6 +1291,7 @@ typeSupplied = true; } else if (key == Keyword.VERSION) { version = value; + versionSupplied = true; } else if (key == Keyword.DEFAULTS) { defaults = coerceToPathname(value); } else if (key == Keyword.CASE) { @@ -1312,6 +1314,9 @@ if (!typeSupplied) { type = defaults.type; } + if (!versionSupplied) { + version = defaults.version; + } } final Pathname p; final boolean logical; @@ -1385,6 +1390,7 @@ p.type = type; } } + p.version = version; return p; } Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/pathname-tests.lisp Tue May 24 05:25:39 2011 (r13293) +++ trunk/abcl/test/lisp/abcl/pathname-tests.lisp Tue May 24 05:25:55 2011 (r13294) @@ -1717,3 +1717,11 @@ (deftest pathname.make-pathname.1 (make-pathname :directory nil :defaults "/home/fare/") #p"") + +(deftest pathname.make-pathname.2 + (let ((p (make-pathname + :defaults (make-pathname :name :wild :type :wild :version :wild :directory :wild)))) + (values + (pathname-name p) (pathname-type p) (pathname-version p) (pathname-directory p))) + :wild :wild :wild (:absolute :wild)) + \ No newline at end of file From mevenson at common-lisp.net Tue Jun 7 15:38:13 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 07 Jun 2011 08:38:13 -0700 Subject: [armedbear-cvs] r13309 - in trunk/abcl: . src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Tue Jun 7 08:38:11 2011 New Revision: 13309 Log: Implementation of hashtables with weak keys and/or values. MAKE-HASH-TABLE now has an optional :WEAKNESS argument that can take the values :KEY, :VALUE, :KEY-AND-VALUE, or :KEY-OR-VALUE. :KEY means that the key of an entry must be live to guarantee that the entry is preserved. VALUE means that the value of an entry must be live to guarantee that the entry is preserved. :KEY-AND-VALUE means that both the key and the value must be live to guarantee that the entry is preserved. :KEY-OR-VALUE means that either the key or the value must be live to guarantee that the entry is preserved. The tests simply excercise the various types of weak hash tables enough that a GC phase should show that the table indeed does decrease in size. Changed the defition of functions in HashTableFunctions to match current docstring/pf_XXX() naming conventions. This implementation is only lightly tested in single-threaded use, and untested in multiple threading scenarios. Addresses ticket:140. Added: trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java trunk/abcl/test/lisp/abcl/weak-hash-tables.lisp Modified: trunk/abcl/abcl.asd trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java trunk/abcl/src/org/armedbear/lisp/Keyword.java trunk/abcl/src/org/armedbear/lisp/make-hash-table.lisp Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd Mon May 30 08:56:46 2011 (r13308) +++ trunk/abcl/abcl.asd Tue Jun 7 08:38:11 2011 (r13309) @@ -55,6 +55,8 @@ ("file-system-tests")) (:file "wild-pathnames" :depends-on ("file-system-tests")) + #+abcl + (:file "weak-hash-tables") #+abcl (:file "pathname-tests" :depends-on ("utilities")))))) Modified: trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Mon May 30 08:56:46 2011 (r13308) +++ trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Tue Jun 7 08:38:11 2011 (r13309) @@ -46,14 +46,18 @@ static final LispObject FUNCTION_EQUALP = Symbol.EQUALP.getSymbolFunction(); - // ### %make-hash-table - private static final Primitive _MAKE_HASH_TABLE = - new Primitive("%make-hash-table", PACKAGE_SYS, false) - { + @DocString(name="%make-hash-table") + private static final Primitive _MAKE_HASH_TABLE + = new pf__make_hash_table(); + private static final class pf__make_hash_table extends Primitive { + pf__make_hash_table() { + super("%make-hash-table", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject test, LispObject size, - LispObject rehashSize, LispObject rehashThreshold) - + LispObject rehashSize, + LispObject rehashThreshold) { final int n = Fixnum.getValue(size); if (test == FUNCTION_EQL || test == NIL) @@ -69,103 +73,192 @@ } }; - // ### gethash key hash-table &optional default => value, present-p - private static final Primitive GETHASH = - new Primitive(Symbol.GETHASH, "key hash-table &optional default") - { + @DocString(name="%make-weak-hash-table") + private static final Primitive _MAKE_WEAK_HASH_TABLE + = new pf__make_weak_hash_table(); + + private static final class pf__make_weak_hash_table extends Primitive { + pf__make_weak_hash_table() { + super("%make-weak-hash-table", PACKAGE_SYS, false); + } + @Override + public LispObject execute(LispObject test, + LispObject size, + LispObject rehashSize, + LispObject rehashThreshold, + LispObject weakness) + { + final int n = Fixnum.getValue(size); + if (test == FUNCTION_EQL || test == NIL) + return WeakHashTable.newEqlHashTable(n, rehashSize, + rehashThreshold, weakness); + if (test == FUNCTION_EQ) + return WeakHashTable.newEqHashTable(n, rehashSize, + rehashThreshold, weakness); + if (test == FUNCTION_EQUAL) + return WeakHashTable.newEqualHashTable(n, rehashSize, + rehashThreshold, weakness); + if (test == FUNCTION_EQUALP) + return WeakHashTable.newEqualpHashTable(n, rehashSize, + rehashThreshold, weakness); + return error(new LispError("Unsupported test for MAKE-HASH-TABLE: " + + test.writeToString())); + } + }; + + @DocString(name="gethash", + args="key hash-table &optional default => value, present-p", + doc="Returns the value associated with KEY in HASH-TABLE.") + private static final Primitive GETHASH + = new pf_gethash(); + private static final class pf_gethash extends Primitive { + pf_gethash() { + super(Symbol.GETHASH, "key hash-table &optional default"); + } + @Override public LispObject execute(LispObject key, LispObject ht) { + if (ht instanceof WeakHashTable) { + return ((WeakHashTable)ht).gethash(key); + } return checkHashTable(ht).gethash(key); } @Override public LispObject execute(LispObject key, LispObject ht, LispObject defaultValue) - { + if (ht instanceof WeakHashTable) { + return ((WeakHashTable)ht).gethash(key, defaultValue); + } return checkHashTable(ht).gethash(key, defaultValue); } }; - // ### gethash1 key hash-table => value - private static final Primitive GETHASH1 = - new Primitive(Symbol.GETHASH1, "key hash-table") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - final HashTable ht = checkHashTable(second); - synchronized (ht) - { - final LispObject value = ht.get(first); - return value != null ? value : NIL; - } + @DocString(name="gethash1", + args="key hash-table => value") + private static final Primitive GETHASH1 + = new pf_gethash1(); + private static final class pf_gethash1 extends Primitive { + pf_gethash1() { + super(Symbol.GETHASH1, "key hash-table"); + } + @Override + public LispObject execute(LispObject first, LispObject second) { + if (second instanceof WeakHashTable) { + final WeakHashTable ht = (WeakHashTable) second; + synchronized (ht) { + final LispObject value = ht.get(first); + return value != null ? value : NIL; + } + } else { + final HashTable ht = checkHashTable(second); + synchronized (ht) { + final LispObject value = ht.get(first); + return value != null ? value : NIL; + } + } } }; // ### puthash key hash-table new-value &optional default => value - private static final Primitive PUTHASH = - new Primitive(Symbol.PUTHASH, - "key hash-table new-value &optional default") - { + @DocString(name="puthash", + args="key hash-table new-value &optional default => value") + private static final Primitive PUTHASH + = new pf_puthash(); + + private static final class pf_puthash extends Primitive { + pf_puthash() { + super(Symbol.PUTHASH, + "key hash-table new-value &optional default"); + } @Override public LispObject execute(LispObject key, LispObject ht, LispObject value) - { - return checkHashTable(ht).puthash(key, value); + if (ht instanceof WeakHashTable) { + return ((WeakHashTable)ht).puthash(key, value); + } + return checkHashTable(ht).puthash(key, value); } @Override public LispObject execute(LispObject key, LispObject ht, LispObject ignored, LispObject value) - { - return checkHashTable(ht).puthash(key, value); + if (ht instanceof WeakHashTable) { + return ((WeakHashTable)ht).puthash(key, value); + } + return checkHashTable(ht).puthash(key, value); } }; - // remhash key hash-table => generalized-boolean - private static final Primitive REMHASH = - new Primitive(Symbol.REMHASH, "key hash-table") - { - @Override - public LispObject execute(LispObject key, LispObject ht) - - { - return checkHashTable(ht).remhash(key); + @DocString(name="remhash", + args="key hash-table => generalized-boolean", + doc="Removes the value for KEY in HASH-TABLE, if any.") + private static final Primitive REMHASH + = new pf_remhash(); + private static final class pf_remhash extends Primitive { + pf_remhash() { + super(Symbol.REMHASH, "key hash-table"); + } + @Override + public LispObject execute(LispObject key, LispObject ht) { + if (ht instanceof WeakHashTable) { + return ((WeakHashTable)ht).remhash(key); + } + return checkHashTable(ht).remhash(key); } }; - // ### clrhash hash-table => hash-table - private static final Primitive CLRHASH = - new Primitive(Symbol.CLRHASH, "hash-table") - { + @DocString(name="clrhash", + args="hash-table => hash-table") + private static final Primitive CLRHASH + = new pf_clrhash(); + private static final class pf_clrhash extends Primitive { + pf_clrhash() { + super(Symbol.CLRHASH, "hash-table"); + } @Override public LispObject execute(LispObject ht) { - checkHashTable(ht).clear(); - return ht; + if (ht instanceof WeakHashTable) { + ((WeakHashTable)ht).clear(); + return ht; + } + checkHashTable(ht).clear(); + return ht; } }; - // ### hash-table-count - private static final Primitive HASH_TABLE_COUNT = - new Primitive(Symbol.HASH_TABLE_COUNT, "hash-table") - { + @DocString(name="hash-table-count", + args="hash-table", + doc="Returns the number of entries in HASH-TABLE.") + private static final Primitive HASH_TABLE_COUNT + = new pf_hash_table_count(); + private static final class pf_hash_table_count extends Primitive { + pf_hash_table_count() { + super(Symbol.HASH_TABLE_COUNT, "hash-table"); + } @Override public LispObject execute(LispObject arg) { + if (arg instanceof WeakHashTable) { + return Fixnum.getInstance(((WeakHashTable)arg).getCount()); + } return Fixnum.getInstance(checkHashTable(arg).getCount()); } }; - // ### sxhash object => hash-code - private static final Primitive SXHASH = - new Primitive(Symbol.SXHASH, "object") - { + @DocString(name="sxhash", + args="object => hash-code") + private static final Primitive SXHASH + = new pf_sxhash(); + private static final class pf_sxhash extends Primitive { + pf_sxhash() { + super(Symbol.SXHASH, "object"); + } @Override public LispObject execute(LispObject arg) { @@ -173,11 +266,15 @@ } }; - // ### psxhash object => hash-code // For EQUALP hash tables. - private static final Primitive PSXHASH = - new Primitive("psxhash", PACKAGE_SYS, true, "object") - { + @DocString(name="psxhash", + args="object") + private static final Primitive PSXHASH + = new pf_psxhash(); + private static final class pf_psxhash extends Primitive { + pf_psxhash() { + super("psxhash", PACKAGE_SYS, true, "object"); + } @Override public LispObject execute(LispObject arg) { @@ -185,87 +282,139 @@ } }; - // ### hash-table-p - private static final Primitive HASH_TABLE_P = - new Primitive(Symbol.HASH_TABLE_P,"object") - { + @DocString(name="hash-table-p", + args="object", + doc="Whether OBJECT is an instance of a hash-table.") + private static final Primitive HASH_TABLE_P + = new pf_hash_table_p(); + private static final class pf_hash_table_p extends Primitive { + pf_hash_table_p(){ + super(Symbol.HASH_TABLE_P,"object"); + } @Override public LispObject execute(LispObject arg) { - return arg instanceof HashTable ? T : NIL; + if (arg instanceof WeakHashTable) return T; + return arg instanceof HashTable ? T : NIL; } }; - // ### hash-table-entries - private static final Primitive HASH_TABLE_ENTRIES = - new Primitive("hash-table-entries", PACKAGE_SYS, false) - { + @DocString(name="hah-table-entries", + args="hash-table", + doc="Returns a list of all key/values pairs in HASH-TABLE.") + private static final Primitive HASH_TABLE_ENTRIES + = new pf_hash_table_entries(); + private static final class pf_hash_table_entries extends Primitive { + pf_hash_table_entries() { + super("hash-table-entries", PACKAGE_SYS, false); + } @Override public LispObject execute(LispObject arg) { + if (arg instanceof WeakHashTable) { + return ((WeakHashTable)arg).ENTRIES(); + } return checkHashTable(arg).ENTRIES(); } }; - // ### hash-table-test - private static final Primitive HASH_TABLE_TEST = - new Primitive(Symbol.HASH_TABLE_TEST, "hash-table") - { - @Override + @DocString(name="hash-table-test", + args="hash-table", + doc="Return the test used for the keys of HASH-TABLE.") + private static final Primitive HASH_TABLE_TEST + = new pf_hash_table_test(); + private static final class pf_hash_table_test extends Primitive { + pf_hash_table_test() { + super(Symbol.HASH_TABLE_TEST, "hash-table"); + } public LispObject execute(LispObject arg) { + if (arg instanceof WeakHashTable) { + return ((WeakHashTable)arg).getTest(); + } return checkHashTable(arg).getTest(); } }; - // ### hash-table-size - private static final Primitive HASH_TABLE_SIZE = - new Primitive(Symbol.HASH_TABLE_SIZE, "hash-table") - { + @DocString(name="hash-table-size", + args="hash-table", + doc="Returns the number of storage buckets in HASH-TABLE.") + private static final Primitive HASH_TABLE_SIZE + = new pf_hash_table_size(); + private static final class pf_hash_table_size extends Primitive { + pf_hash_table_size() { + super(Symbol.HASH_TABLE_SIZE, "hash-table"); + } @Override public LispObject execute(LispObject arg) { + if (arg instanceof WeakHashTable) { + return Fixnum.getInstance(((WeakHashTable)arg).getSize()); + } return Fixnum.getInstance(checkHashTable(arg).getSize()); } }; - // ### hash-table-rehash-size - private static final Primitive HASH_TABLE_REHASH_SIZE = - new Primitive(Symbol.HASH_TABLE_REHASH_SIZE, "hash-table") - { + @DocString(name="hash-table-rehash-size", + args="hash-table") + private static final Primitive HASH_TABLE_REHASH_SIZE + = new pf_hash_table_rehash_size(); + private static final class pf_hash_table_rehash_size extends Primitive { + pf_hash_table_rehash_size() { + super(Symbol.HASH_TABLE_REHASH_SIZE, "hash-table"); + } @Override public LispObject execute(LispObject arg) { + if (arg instanceof WeakHashTable) { + return ((WeakHashTable)arg).getRehashSize(); + } return checkHashTable(arg).getRehashSize(); } }; - // ### hash-table-rehash-threshold - private static final Primitive HASH_TABLE_REHASH_THRESHOLD = - new Primitive(Symbol.HASH_TABLE_REHASH_THRESHOLD, "hash-table") - { + @DocString(name="hash-table-rehash-threshold", + args="hash-table") + private static final Primitive HASH_TABLE_REHASH_THRESHOLD + = new pf_hash_table_rehash_threshold(); + private static final class pf_hash_table_rehash_threshold extends Primitive { + pf_hash_table_rehash_threshold() { + super(Symbol.HASH_TABLE_REHASH_THRESHOLD, "hash-table"); + } @Override public LispObject execute(LispObject arg) { + if (arg instanceof WeakHashTable) { + return ((WeakHashTable)arg).getRehashThreshold(); + } return checkHashTable(arg).getRehashThreshold(); } }; - // ### maphash - private static final Primitive MAPHASH = - new Primitive(Symbol.MAPHASH, "function hash-table") - { + @DocString(name="maphash", + args="function hash-table", + doc="Iterates over all entries in the hash-table. For each entry," + + " the function is called with two arguments--the key and the" + + " value of that entry.") + private static final Primitive MAPHASH + = new pf_maphash(); + private static final class pf_maphash extends Primitive { + pf_maphash() { + super(Symbol.MAPHASH, "function hash-table"); + } @Override public LispObject execute(LispObject first, LispObject second) - { + if (second instanceof WeakHashTable) { + return ((WeakHashTable)second).MAPHASH(first); + } return checkHashTable(second).MAPHASH(first); } }; -protected static HashTable checkHashTable(LispObject ht) { - if (ht instanceof HashTable) return (HashTable)ht; + protected static HashTable checkHashTable(LispObject ht) { + if (ht instanceof HashTable) return (HashTable)ht; type_error(ht, Symbol.HASH_TABLE); - return null; -} + return null; + } } Modified: trunk/abcl/src/org/armedbear/lisp/Keyword.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Keyword.java Mon May 30 08:56:46 2011 (r13308) +++ trunk/abcl/src/org/armedbear/lisp/Keyword.java Tue Jun 7 08:38:11 2011 (r13309) @@ -98,6 +98,8 @@ JAVA_1_6 = internKeyword("JAVA-1.6"), JAVA_1_7 = internKeyword("JAVA-1.7"), KEY = internKeyword("KEY"), + KEY_AND_VALUE = internKeyword("KEY-AND-VALUE"), + KEY_OR_VALUE = internKeyword("KEY-OR-VALUE"), LINUX = internKeyword("LINUX"), LOAD_TOPLEVEL = internKeyword("LOAD-TOPLEVEL"), LOCAL = internKeyword("LOCAL"), @@ -144,6 +146,7 @@ UP = internKeyword("UP"), UPCASE = internKeyword("UPCASE"), USE = internKeyword("USE"), + VALUE = internKeyword("VALUE"), VERSION = internKeyword("VERSION"), WILD = internKeyword("WILD"), WILD_INFERIORS = internKeyword("WILD-INFERIORS"), Added: trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Tue Jun 7 08:38:11 2011 (r13309) @@ -0,0 +1,928 @@ +/* + * HashTable.java + * + * Copyright (C) 2002-2007 Peter Graves + * Copyright (C) 2010 Erik Huelsmann + * Copyright (C) 2011 Mark Evenson + * $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., 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 static org.armedbear.lisp.Lisp.*; + +import java.lang.ref.WeakReference; +import java.lang.ref.Reference; +import java.lang.ref.ReferenceQueue; +import java.util.Collections; +import java.util.HashMap; +import java.util.Map; +import java.util.concurrent.locks.ReentrantLock; + + + + + +// ??? Replace standard Hashtable when this code is working; maybe not +// because we have additional places for locking here. +// +// We can't simply extend HashTable as the methods returning HashEntry +// are referring to different types as HashEntry is internal to this +// class. +// +// XXX individuals are invited to figure out how to use Java generics +// to simplify/beautify things here, but I couldn't get the +// WeakHashTable type to be parameterized on an enclosed type. +public class WeakHashTable + extends LispObject +{ + protected static final float loadFactor = 0.75f; + protected final LispObject rehashSize; + protected final LispObject rehashThreshold; + /** + * The rounded product of the capacity and the load factor. When the number + * of elements exceeds the threshold, the implementation calls rehash(). + */ + protected int threshold; + /** Array containing the actual key-value mappings. */ + @SuppressWarnings("VolatileArrayField") + protected volatile HashEntry[] buckets; + /** The actual current number of key-value pairs. */ + protected volatile int count; + final Comparator comparator; + final private ReentrantLock lock = new ReentrantLock(); + HashEntry bucketType; + + private WeakHashTable(Comparator c, int size, LispObject rehashSize, + LispObject rehashThreshold, LispObject weakness) + { + this.rehashSize = rehashSize; + this.rehashThreshold = rehashThreshold; + bucketType = null; + if (weakness.equals(Keyword.KEY)) { + bucketType = this.new HashEntryWeakKey(); + } else if (weakness.equals(Keyword.VALUE)) { + bucketType = this.new HashEntryWeakValue(); + } else if (weakness.equals(Keyword.KEY_AND_VALUE)) { + bucketType = this.new HashEntryWeakKeyAndValue(); + } else if (weakness.equals(Keyword.KEY_OR_VALUE)) { + bucketType = this.new HashEntryWeakKeyOrValue(); + } else { + // We handle this check in the wrapping Lisp code. + assert false + : "Bad weakness argument to WeakHashTable type constructor."; + } + buckets = bucketType.makeArray(size); + threshold = (int) (size * loadFactor); + comparator = c; + } + + protected static int calculateInitialCapacity(int size) { + int capacity = 1; + while (capacity < size) { + capacity <<= 1; + } + return capacity; + } + + // XXX only WEAK references types are implemented for WeakHashTable. + // XXX This enum is currently unused in this code + enum ReferenceType { + NORMAL, + WEAK, + SOFT + } + + // XXX This enum is currently unused in this code + enum WeaknessType { + /** KEY means that the key of an entry must be live to + guarantee that the entry is preserved. */ + KEY, + /** VALUE means that the value of an entry must be live to + guarantee that the entry is preserved. */ + VALUE, + /** KEY-AND-VALUE means that both the key and the value + must be live to guarantee that the entry is preserved. */ + KEY_AND_VALUE, + /** KEY-OR-VALUE means that either the key or the value + must be live to guarantee that the entry is preserved. */ + KEY_OR_VALUE + } + + public static WeakHashTable newEqHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold, + LispObject weakness) + { + return new WeakHashTable(new Comparator(), size, + rehashSize, rehashThreshold, weakness); + } + + public static WeakHashTable newEqlHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold, + LispObject weakness) + { + return new WeakHashTable(new EqlComparator(), size, + rehashSize, rehashThreshold, weakness); + } + + public static WeakHashTable newEqualHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold, + LispObject weakness) + { + return new WeakHashTable(new EqualComparator(), size, + rehashSize, rehashThreshold, weakness); + } + + public static WeakHashTable newEqualpHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold, + LispObject weakness) + { + return new WeakHashTable(new EqualpComparator(), size, + rehashSize, rehashThreshold, weakness); + } + + public final LispObject getRehashSize() { + return rehashSize; + } + + public final LispObject getRehashThreshold() { + return rehashThreshold; + } + + /** How many hash buckets exist in the underlying data structure. */ + public int getSize() { + HashEntry[] b = getTable(); + return b.length; + } + + /** Number of entries stored in the hash buckets. */ + public int getCount() { + getTable(); // To force gc on entries + return count; + } + + @Override + public LispObject typeOf() { + return Symbol.HASH_TABLE; + } + + @Override + public LispObject classOf() { + return BuiltInClass.HASH_TABLE; + } + + @Override + public LispObject typep(LispObject type) { + if (type == Symbol.HASH_TABLE) { + return T; + } + if (type == BuiltInClass.HASH_TABLE) { + return T; + } + return super.typep(type); + } + + // XXX Not thread-safe as hash entries can be GCd "out from under" + // the invoking thread. But the HashTable implementation + // seemingly suffers from the same problem if entries are + // removed/added while this method executes. + @Override + public boolean equalp(LispObject obj) { + if (this == obj) { + return true; + } + if (obj instanceof WeakHashTable) { + WeakHashTable ht = (WeakHashTable) obj; + if (count != ht.count) { + return false; + } + if (getTest() != ht.getTest()) { + return false; + } + LispObject entries = ENTRIES(); + while (entries != NIL) { + LispObject entry = entries.car(); + LispObject key = entry.car(); + LispObject value = entry.cdr(); + if (!value.equalp(ht.get(key))) { + return false; + } + entries = entries.cdr(); + } + return true; + } + return false; + } + + @Override + public LispObject getParts() { + HashEntry[] b = getTable();; + LispObject parts = NIL; + for (int i = 0; i < b.length; i++) { + HashEntry e = b[i]; + while (e != null) { + LispObject key = e.getKey(); + LispObject value = e.getValue(); + if (key != null && value != null) { + parts = parts.push(new Cons("KEY [bucket " + i + "]", key)); + parts = parts.push(new Cons("VALUE", value)); + } else { + assert false + : "Dangling hash entries encountered."; + } + e = e.getNext(); + } + } + return parts.nreverse(); + } + + public void clear() { + lock.lock(); + try { + buckets = bucketType.makeArray(buckets.length); + count = 0; + while (queue.poll() != null) + ; + } finally { + lock.unlock(); + } + } + + // gethash key hash-table &optional default => value, present-p + public LispObject gethash(LispObject key) { + LispObject value = get(key); + final LispObject presentp; + if (value == null) { + value = presentp = NIL; + } else { + presentp = T; + } + return LispThread.currentThread().setValues(value, presentp); + } + + // gethash key hash-table &optional default => value, present-p + public LispObject gethash(LispObject key, LispObject defaultValue) { + LispObject value = get(key); + final LispObject presentp; + if (value == null) { + value = defaultValue; + presentp = NIL; + } else { + presentp = T; + } + return LispThread.currentThread().setValues(value, presentp); + } + + public LispObject gethash1(LispObject key) { + final LispObject value = get(key); + return value != null ? value : NIL; + } + + public LispObject puthash(LispObject key, LispObject newValue) { + put(key, newValue); + return newValue; + } + + // remhash key hash-table => generalized-boolean + public LispObject remhash(LispObject key) { + // A value in a Lisp hash table can never be null, so... + return remove(key) != null ? T : NIL; + } + + @Override + public String writeToString() { + if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL) { + error(new PrintNotReadable(list(Keyword.OBJECT, this))); + return null; // Not reached. + } + StringBuilder sb = new StringBuilder(getTest().writeToString()); + sb.append(' '); + sb.append(Symbol.HASH_TABLE.writeToString()); + sb.append(' '); + if (bucketType instanceof HashEntryWeakKey) { + sb.append("WEAKNESS :KEY"); + } else if (bucketType instanceof HashEntryWeakValue) { + sb.append("WEAKNESS :VALUE"); + } else if (bucketType instanceof HashEntryWeakKeyAndValue) { + sb.append("WEAKNESS :KEY-AND-VALUE"); + } else if (bucketType instanceof HashEntryWeakKeyOrValue) { + sb.append("WEAKNESS :KEY-OR-VALUE"); + } + sb.append(' '); + sb.append(count); + if (count == 1) { + sb.append(" entry"); + } else { + sb.append(" entries"); + } + sb.append(", "); + sb.append(buckets.length); + sb.append(" buckets"); + return unreadableString(sb.toString()); + } + + public Symbol getTest() { + return comparator.getTest(); + } + + HashEntry[] getTable() { + lock.lock(); + try { + bucketType.expungeQueue(); + return buckets; + } finally { + lock.unlock(); + } + } + + protected HashEntry getEntry(LispObject key) { + HashEntry[] b = getTable(); + int hash = comparator.hash(key); + HashEntry e = b[hash & (b.length - 1)]; + while (e != null) { + if (hash == e.getHash() + && (key == e.getKey() + || comparator.keysEqual(key, e.getKey()))) { + return e; + } + e = e.getNext(); + } + return null; + } + + public LispObject get(LispObject key) { + HashEntry e = getEntry(key); + LispObject v = (e == null) ? null : e.getValue(); + + if (e == null || v != null) { + return v; + } + return e.getValue(); + } + + public void put(LispObject key, LispObject value) { + HashEntry e = getEntry(key); + if (e != null) { + e.setValue(value); + } else { + // Not found. We need to add a new entry. + if (++count > threshold) { + rehash(); + } + int hash = comparator.hash(key); + int index = hash & (buckets.length - 1); + buckets[index] = bucketType.makeInstance(key, hash, + value, buckets[index], + index); + } + } + + public LispObject remove(LispObject key) { + lock.lock(); + try { + bucketType.expungeQueue(); + int index = comparator.hash(key) & (buckets.length - 1); + + HashEntry e = buckets[index]; + HashEntry last = null; + while (e != null) { + LispObject entryKey = e.getKey(); + if (entryKey == null) { + e.clear(); + if (last == null) { + buckets[index] = e.getNext(); + } else { + last.setNext(e.getNext()); + } + --count; + } else if (comparator.keysEqual(key, entryKey)) { + e.clear(); + if (last == null) { + buckets[index] = e.getNext(); + } else { + last.setNext(e.getNext()); + } + --count; + return e.getValue(); + } + last = e; + e = e.getNext(); + } + return null; + } finally { + lock.unlock(); + } + } + + + /** + * Internal removal of the HashEntry associated with the + * Reference used for a hashtables with soft/weak references. + */ + private void remove(Reference ref) { + assert lock.isHeldByCurrentThread(); + HashEntry entry = entryLookup.get(ref); + // assert entry != null + // : "Failed to find hash entry for reference."; + if (entry == null) { + return; // XXX how does this happen? + } + int index = entry.getSlot(); + HashEntry e = this.buckets[index]; + HashEntry last = null; + while (e != null) { + if (e.equals(entry)) { + if (last == null) { + this.buckets[index] = e.getNext(); + } else { + last.setNext(e.getNext()); + } + --count; + break; + } + last = e; + e = e.getNext(); + } + } + + protected void rehash() { + lock.lock(); + try { + final int newCapacity = buckets.length * 2; + threshold = (int) (newCapacity * loadFactor); + int mask = newCapacity - 1; + HashEntry[] newBuckets = bucketType.makeArray(newCapacity); + + for (int i = buckets.length; i-- > 0;) { + HashEntry e = buckets[i]; + while (e != null) { + LispObject key = e.getKey(); + LispObject value = e.getValue(); + if (key == null || value == null) { + e.clear(); + e = e.getNext(); + continue; + } + final int index = comparator.hash(key) & mask; + e.clear(); + newBuckets[index] + = bucketType.makeInstance(key, + e.getHash(), + value, + newBuckets[index], + index); + e = e.getNext(); + } + } + buckets = newBuckets; + } finally { + lock.unlock(); + } + } + + // Returns a list of (key . value) pairs. + public LispObject ENTRIES() { + HashEntry[] b = getTable(); + LispObject list = NIL; + for (int i = b.length; i-- > 0;) { + HashEntry e = b[i]; + while (e != null) { + LispObject key = e.getKey(); + LispObject value = e.getValue(); + if (key != null && value != null) { + list = new Cons(new Cons(key, value), list); + } else { + assert false + : "ENTRIES encounted dangling entries."; + } + e = e.getNext(); + } + } + return list; + } + + public LispObject MAPHASH(LispObject function) { + HashEntry[] b = getTable(); + for (int i = b.length; i-- > 0;) { + HashEntry e = b[i]; + while (e != null) { + LispObject key = e.getKey(); + LispObject value = e.getValue(); + if (key != null && value != null) { + function.execute(key, value); + } else { + assert false + : "MAPHASH encountered dangling entries."; + } + e = e.getNext(); + } + } + return NIL; + } + + protected static class Comparator { + Symbol getTest() { + return Symbol.EQ; + } + + boolean keysEqual(LispObject key1, LispObject key2) { + return key1 == key2; + } + + int hash(LispObject key) { + return key.sxhash(); + } + } + + protected static class EqlComparator extends Comparator { + @Override + Symbol getTest() { + return Symbol.EQL; + } + + @Override + boolean keysEqual(LispObject key1, LispObject key2) { + return key1.eql(key2); + } + } + + protected static class EqualComparator extends Comparator { + @Override + Symbol getTest() { + return Symbol.EQUAL; + } + + @Override + boolean keysEqual(LispObject key1, LispObject key2) { + return key1.equal(key2); + } + } + + protected static class EqualpComparator extends Comparator { + @Override + Symbol getTest() { + return Symbol.EQUALP; + } + + @Override + boolean keysEqual(LispObject key1, LispObject key2) { + return key1.equalp(key2); + } + + @Override + int hash(LispObject key) { + return key.psxhash(); + } + } + + abstract class HashEntry + { + LispObject key; + int hash; + volatile LispObject value; + HashEntry next; + int slot; + + public HashEntry() {}; + + public HashEntry(LispObject key, int hash, LispObject value, + HashEntry next, int slot) + { + this.key = key; + this.hash = hash; + this.value = value; + this.next = next; + this.slot = slot; + } + + public LispObject getKey() { + return key; + } + + public void setKey(LispObject key) { + this.key = key; + } + + public int getHash() { + return hash; + } + + public void setHash(int hash) { + this.hash = hash; + } + + public LispObject getValue() { + return value; + } + + public void setValue(LispObject value) { + this.value = value; + } + + public HashEntry getNext() { + return next; + } + + public void setNext(HashEntry next) { + this.next = next; + } + + public int getSlot() { + return slot; + } + + public void setSlot(int slot) { + this.slot = slot; + } + + abstract HashEntry[] makeArray(int length); + + abstract HashEntry makeInstance(LispObject key, int hash, + LispObject value, + HashEntry next, int slot); + abstract void expungeQueue(); + abstract void clear(); + } + + ReferenceQueue queue + = new ReferenceQueue(); + + Map entryLookup + = Collections.synchronizedMap(new HashMap()); + + class HashEntryWeakKey + extends HashEntry + { + private WeakReference key; + + public HashEntryWeakKey() {}; + + public HashEntryWeakKey(LispObject key, int hash, LispObject value, + HashEntry next, int slot) + { + this.hash = hash; + this.value = value; + this.next = next; + this.slot = slot; + + this.key = new WeakReference(key, queue); + entryLookup.put(this.key, this); + } + + public LispObject getKey() { + return key.get(); + } + + public void setKey(LispObject key) { + java.lang.ref.WeakReference old = this.key; + old.clear(); + this.key = new WeakReference(key, queue); + entryLookup.put(this.key, this); + } + + HashEntryWeakKey[] makeArray(int length) { + return new HashEntryWeakKey[length]; + } + + HashEntry makeInstance(LispObject key, int hash, LispObject value, + HashEntry next, int slot) + { + return new HashEntryWeakKey(key, hash, value, next, slot); + } + + void expungeQueue() { + Reference ref = queue.poll(); + while (ref != null) { + WeakHashTable.this.remove(ref); + entryLookup.remove(ref); + ref = queue.poll(); + } + } + + /** Remove referenced objects from GC queue structures. */ + void clear() { + key.clear(); + assert entryLookup.containsKey(key) + : "Key was not in lookup table"; + entryLookup.remove(key); + } + } + + class HashEntryWeakValue + extends HashEntry + { + private WeakReference value; + + public HashEntryWeakValue() {}; + + public HashEntryWeakValue(LispObject key, int hash, LispObject value, + HashEntry next, int slot) + { + this.hash = hash; + this.key = key; + this.next = next; + this.slot = slot; + + this.value = new WeakReference(value, queue); + entryLookup.put(this.value, this); + } + + public LispObject getValue() { + return value.get(); + } + + public void setValue(LispObject value) { + java.lang.ref.WeakReference old = this.value; + old.clear(); + this.value = new WeakReference(value, queue); + entryLookup.put(this.value, this); + } + + HashEntryWeakValue[] makeArray(int length) { + return new HashEntryWeakValue[length]; + } + + HashEntryWeakValue makeInstance(LispObject key, int hash, LispObject value, + HashEntry next, int slot) + { + return new HashEntryWeakValue(key, hash, value, next, slot); + } + + void expungeQueue() { + Reference ref = queue.poll(); + while (ref != null) { + WeakHashTable.this.remove(ref); + entryLookup.remove(ref); + ref = queue.poll(); + } + } + + /** Remove referenced objects from GC queue structures. */ + void clear() { + value.clear(); + assert entryLookup.containsKey(value) + : "Value was not in lookup table."; + entryLookup.remove(value); + } + } + + class HashEntryWeakKeyAndValue + extends HashEntry + { + private WeakReference key; + private WeakReference value; + + public HashEntryWeakKeyAndValue() {}; + + public HashEntryWeakKeyAndValue(LispObject key, int hash, + LispObject value, + HashEntry next, int slot) + { + this.hash = hash; + this.next = next; + this.slot = slot; + + this.key = new WeakReference(key, queue); + entryLookup.put(this.key, this); + + this.value = new WeakReference(value, queue); + entryLookup.put(this.value, this); + + } + + public LispObject getKey() { + return key.get(); + } + + public void setKey(LispObject key) { + java.lang.ref.WeakReference old = this.key; + entryLookup.remove(old); + old.clear(); + this.key = new WeakReference(key, queue); + entryLookup.put(this.key, this); + } + + public LispObject getValue() { + return value.get(); + } + + public void setValue(LispObject value) { + java.lang.ref.WeakReference old = this.value; + entryLookup.remove(old); + old.clear(); + this.value = new WeakReference(value, queue); + entryLookup.put(this.value, this); + } + + HashEntryWeakKeyAndValue[] makeArray(int length) { + return new HashEntryWeakKeyAndValue[length]; + } + + HashEntryWeakKeyAndValue makeInstance(LispObject key, int hash, + LispObject value, + HashEntry next, int slot) + { + return new HashEntryWeakKeyAndValue(key, hash, value, next, slot); + } + + void expungeQueue() { + Reference ref = queue.poll(); + while (ref != null) { + HashEntry entry = entryLookup.get(ref); + if (entry == null) { + ref = queue.poll(); + continue; + } + if (entry.getKey() == null + && entry.getValue() == null) { + WeakHashTable.this.remove(ref); + entryLookup.remove(ref); + } else { + entryLookup.remove(ref); + } + ref = queue.poll(); + } + } + + /** Remove referenced objects from GC queue structures. */ + void clear() { + key.clear(); + value.clear(); + entryLookup.remove(key); + entryLookup.remove(value); + } + } + + class HashEntryWeakKeyOrValue + extends HashEntryWeakKeyAndValue + { + public HashEntryWeakKeyOrValue() {}; + + public HashEntryWeakKeyOrValue(LispObject key, int hash, + LispObject value, + HashEntry next, int slot) + { + super(key, hash, value, next, slot); + } + HashEntryWeakKeyOrValue[] makeArray(int length) { + return new HashEntryWeakKeyOrValue[length]; + } + + HashEntryWeakKeyOrValue makeInstance(LispObject key, int hash, + LispObject value, + HashEntry next, int slot) + { + return new HashEntryWeakKeyOrValue(key, hash, value, next, slot); + } + + void expungeQueue() { + Reference ref = queue.poll(); + while (ref != null) { + HashEntry entry = entryLookup.get(ref); + if (entry == null) { + ref = queue.poll(); + continue; + } + WeakHashTable.this.remove(ref); + entryLookup.remove(entry.key); + entryLookup.remove(entry.value); + ref = queue.poll(); + } + } + } + + // For EQUALP hash tables. + @Override + public int psxhash() { + long result = 2062775257; // Chosen at random. + result = mix(result, count); + result = mix(result, getTest().sxhash()); + return (int) (result & 0x7fffffff); + } +} Modified: trunk/abcl/src/org/armedbear/lisp/make-hash-table.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/make-hash-table.lisp Mon May 30 08:56:46 2011 (r13308) +++ trunk/abcl/src/org/armedbear/lisp/make-hash-table.lisp Tue Jun 7 08:38:11 2011 (r13309) @@ -32,9 +32,23 @@ (in-package #:system) (defun make-hash-table (&key (test 'eql) (size 11) (rehash-size 1.5) - (rehash-threshold 0.75)) + (rehash-threshold 0.75) + (weakness nil)) (setf test (coerce-to-function test)) (unless (and (integerp size) (>= size 0)) (error 'type-error :datum size :expected-type '(integer 0))) - (let ((size (max 11 (min size array-dimension-limit)))) - (%make-hash-table test size rehash-size rehash-threshold))) + (let ((size (max 11 (min size array-dimension-limit))) + (weakness-types '(or (eql :key) (eql :value) + (eql :key-and-value) + (eql :key-or-value)))) + (if weakness + (if (not (typep weakness weakness-types)) + (error 'type-error :datum weakness + :expected-type weakness-types) + (%make-weak-hash-table test size rehash-size + rehash-threshold weakness)) + (%make-hash-table test size + rehash-size rehash-threshold)))) + + + Added: trunk/abcl/test/lisp/abcl/weak-hash-tables.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/test/lisp/abcl/weak-hash-tables.lisp Tue Jun 7 08:38:11 2011 (r13309) @@ -0,0 +1,76 @@ +(in-package #:abcl.test.lisp) + +#| +(deftest weak-hash-table.1 + (labels ((random-key () + (coerce (/ (random 10000) (random 10000)) + 'single-float))) + (let ((ht (make-hash-table :weakness :keys)) + (dotimes (i 1000) + (setf (gethash (random-key) ht) (random 100000)) + (sys::hash-table-entries ht) + +|# + +(defun random-object () + "A randomly constructed object that is elgible for garbage collection." + (coerce (/ (random 10000) (1+ (random 10000))) + 'single-float)) + +(deftest weak-hash-table.1 + (let* ((ht (make-hash-table :weakness :key)) + (entries 0)) + (dotimes (i 100000) + (setf (gethash (random-object) ht) (random 100000)) + (let ((new-entries (sys::hash-table-count ht))) + (when (and new-entries + (> entries new-entries)) + (format t "~&Previously ~A entries, now ~A." + entries new-entries)) + (setf entries new-entries)))) + nil) + +(deftest weak-hash-table.2 + (let* ((ht (make-hash-table :weakness :value)) + (entries 0)) + (dotimes (i 100000) + (setf (gethash (random-object) ht) (random 100000)) + (let ((new-entries (sys::hash-table-count ht))) + (when (and new-entries + (> entries new-entries)) + (format t "~&Previously ~A entries, now ~A." + entries new-entries)) + (setf entries new-entries)))) + nil) + +(deftest weak-hash-table.3 + (let* ((ht (make-hash-table :weakness :key-and-value)) + (entries 0)) + (dotimes (i 100000) + (setf (gethash (random-object) ht) (random 100000)) + (let ((new-entries (sys::hash-table-count ht))) + (when (and new-entries + (> entries new-entries)) + (format t "~&Previously ~A entries, now ~A." + entries new-entries)) + (setf entries new-entries)))) + nil) + +(deftest weak-hash-table.4 + (let* ((ht (make-hash-table :weakness :key-or-value)) + (entries 0)) + (dotimes (i 100000) + (setf (gethash (random-object) ht) (random 100000)) + (let ((new-entries (sys::hash-table-count ht))) + (when (and new-entries + (> entries new-entries)) + (format t "~&Previously ~A entries, now ~A." + entries new-entries)) + (setf entries new-entries)))) + nil) + + + + + + From mevenson at common-lisp.net Tue Jun 7 18:07:36 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 07 Jun 2011 11:07:36 -0700 Subject: [armedbear-cvs] r13310 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jun 7 11:07:33 2011 New Revision: 13310 Log: SYS:HASH-TABLE-WEAKNESS provides the weakness property of a hashtable. Modified: trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Tue Jun 7 08:38:11 2011 (r13309) +++ trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Tue Jun 7 11:07:33 2011 (r13310) @@ -412,6 +412,27 @@ } }; + @DocString(name="hash-table-weakness", + args="hash-table", + doc="Return weakness property of HASH-TABLE, or NIL if it has none.") + private static final Primitive HASH_TABLE_WEAKNESS + = new pf_hash_table_weakness(); + private static final class pf_hash_table_weakness extends Primitive { + pf_hash_table_weakness() { + super(Symbol.HASH_TABLE_WEAKNESS, "hash-table"); + } + @Override + public LispObject execute(LispObject first) + { + if (first instanceof HashTable) { + return NIL; + } else if (first instanceof WeakHashTable) { + return ((WeakHashTable)first).getWeakness(); + } + return error(new TypeError(first, Symbol.HASH_TABLE)); + } + }; + protected static HashTable checkHashTable(LispObject ht) { if (ht instanceof HashTable) return (HashTable)ht; type_error(ht, Symbol.HASH_TABLE); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Tue Jun 7 08:38:11 2011 (r13309) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Tue Jun 7 11:07:33 2011 (r13310) @@ -3045,6 +3045,8 @@ PACKAGE_SYS.addExternalSymbol("GETHASH1"); public static final Symbol PUTHASH = PACKAGE_SYS.addExternalSymbol("PUTHASH"); + public static final Symbol HASH_TABLE_WEAKNESS = + PACKAGE_SYS.addExternalSymbol("HASH-TABLE-WEAKNESS"); public static final Symbol UNDEFINED_FUNCTION_CALLED = PACKAGE_SYS.addExternalSymbol("UNDEFINED-FUNCTION-CALLED"); public static final Symbol SET_CHAR = Modified: trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Tue Jun 7 08:38:11 2011 (r13309) +++ trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Tue Jun 7 11:07:33 2011 (r13310) @@ -45,10 +45,6 @@ import java.util.Map; import java.util.concurrent.locks.ReentrantLock; - - - - // ??? Replace standard Hashtable when this code is working; maybe not // because we have additional places for locking here. // @@ -78,6 +74,7 @@ final Comparator comparator; final private ReentrantLock lock = new ReentrantLock(); HashEntry bucketType; + final LispObject weakness; private WeakHashTable(Comparator c, int size, LispObject rehashSize, LispObject rehashThreshold, LispObject weakness) @@ -85,6 +82,7 @@ this.rehashSize = rehashSize; this.rehashThreshold = rehashThreshold; bucketType = null; + this.weakness = weakness; if (weakness.equals(Keyword.KEY)) { bucketType = this.new HashEntryWeakKey(); } else if (weakness.equals(Keyword.VALUE)) { @@ -350,6 +348,10 @@ public Symbol getTest() { return comparator.getTest(); } + + public LispObject getWeakness() { + return weakness; + } HashEntry[] getTable() { lock.lock(); From mevenson at common-lisp.net Wed Jun 8 05:23:26 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 07 Jun 2011 22:23:26 -0700 Subject: [armedbear-cvs] r13311 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jun 7 22:23:25 2011 New Revision: 13311 Log: Update to asdf-2.016. Modified: trunk/abcl/doc/asdf/asdf.texinfo trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/doc/asdf/asdf.texinfo ============================================================================== --- trunk/abcl/doc/asdf/asdf.texinfo Tue Jun 7 11:07:33 2011 (r13310) +++ trunk/abcl/doc/asdf/asdf.texinfo Tue Jun 7 22:23:25 2011 (r13311) @@ -171,9 +171,24 @@ @emph{Nota Bene}: We have released ASDF 2.000 on May 31st 2010. -It hopefully will have been it included -in all CL maintained implementations shortly afterwards. +Subsequent releases of ASDF 2 have since then been included +in all actively maintained CL implementations that used to bundle ASDF 1, +plus some implementations that didn't use to, +and has been made to work with all actively used CL implementations and a few more. @xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. +Furthermore, it is possible to upgrade from ASDF 1 to ASDF 2 on the fly. +For this reason, we have stopped supporting ASDF 1; +if you are using ASDF 1 and are experiencing any kind of issues or limitations, +we recommend you upgrade to ASDF 2 +--- and we explain how to do that. @xref{Loading ASDF}. + +Also note that ASDF is not to be confused with ASDF-Install. +ASDF-Install is not part of ASDF, but a separate piece of software. +ASDF-Install is also unmaintained and obsolete. +We recommend you use Quicklisp instead, +which works great and is being actively maintained. +If you want to download software from version control instead of tarballs, +so you may more easily modify it, we recommend clbuild. @node Loading ASDF, Configuring ASDF, Introduction, Top @@ -199,17 +214,27 @@ You can usually load this copy using Common Lisp's @code{require} function: @lisp -(require :asdf) +(require "asdf") @end lisp -Consult your Lisp implementation's documentation for details. +As of the writing of this manual, +the following implementations provide ASDF 2 this way: +abcl allegro ccl clisp cmucl ecl sbcl xcl. +The following implementations don't provide it yet but will in a future release: +lispworks scl. +The following implementations are obsolete and most probably will never bundle it: +cormancl gcl genera mcl. + +If the implementation you are using doesn't provide ASDF 2, +see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below. +If that implementation is still actively maintained, +you may also send a bug report to your Lisp vendor and complain +about their failing to provide ASDF. + +NB: all implementations except clisp also accept + at code{(require "ASDF")}, @code{(require 'asdf)} and @code{(require :asdf)}. +For portability's sake, you probably want to use @code{(require "asdf")}. -Hopefully, ASDF 2 will soon be bundled with every Common Lisp implementation, -and you can load it that way. -If it is not, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below. -if you are using the latest version of your Lisp vendor's software, -you may also send a bug report to your Lisp vendor and complain about -their failing to provide ASDF. @section Checking whether ASDF is loaded @@ -242,8 +267,10 @@ 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 2.008, -we recommend that you load a newer ASDF using the method below. +If you are experiencing problems with ASDF, +please try upgrading to the latest released version, +using the method below, +before you contact us and raise an issue. @section Upgrading ASDF @@ -256,7 +283,7 @@ and upgrade with: @lisp -(require :asdf) +(require "asdf") (asdf:load-system :asdf) @end lisp @@ -264,7 +291,7 @@ you will require a special configuration step and an old-style loading: @lisp -(require :asdf) +(require "asdf") (push #p"@var{/path/to/new/asdf/}" asdf:*central-registry*) (asdf:oos 'asdf:load-op :asdf) @end lisp @@ -279,15 +306,39 @@ for multiple mutually incompatible implementations. At worst, you may have to have multiple copies of the new ASDF, e.g. one per implementation installation, to avoid clashes. +Note that to our knowledge all implementations that provide ASDF +provide ASDF 2 in their latest release, so +you may want to upgrade your implementation rather than go through that hoop. Finally, note that there are some limitations to upgrading ASDF: @itemize @item -Any ASDF extension is invalidated, and will need to be reloaded. +Any ASDF extension becomes invalid, and will need to be reloaded. +This applies to e.g. CFFI-Grovel, or to hacks used by ironclad, etc. +Starting with ASDF 2.014.8, ASDF will actually invalidate +all previously loaded systems when it is loaded on top of +a different ASDF version. @item -It is safer if you upgrade ASDF and its extensions as a special step +Until all implementations provide ASDF 2.015 or later, +it is safer if you upgrade ASDF and its extensions as a special step at the very beginning of whatever script you are running, before you start using ASDF to load anything else. + at item +Until all implementations provide ASDF 2.015 or later, +it is unsafe to upgrade ASDF as part of loading a system +that depends on a more recent version of ASDF, +since the new one might shadow the old one while the old one is running, +and the running old one will be confused +when extensions are loaded into the new one. +In the meantime, we recommend that your systems should @emph{not} specify + at code{:depends-on (:asdf)}, or @code{:depends-on ((:version :asdf "2.010"))}, +but instead that they check that a recent enough ASDF is installed, +with such code as: + at example +(unless (or #+asdf2 (asdf:version-satisfies + (asdf:asdf-version) *required-asdf-version*)) + (error "FOO requires ASDF ~A or later." *required-asdf-version*)) + at end example @end itemize @@ -337,14 +388,15 @@ If you install software there, you don't need further configuration. If you're installing software yourself at a location that isn't standard, you have to tell ASDF where you installed it. See below. -If you're using some tool to install software, +If you're using some tool to install software (e.g. Quicklisp), the authors of that tool should already have configured ASDF. The simplest way to add a path to your search path, 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 but the type @file{conf}, +and there create a file with any name of your choice, +and with the type @file{conf}, for instance @file{42-asd-link-farm.conf} containing the line: @@ -404,7 +456,7 @@ For instance, if you wanted ASDF to find the @file{.asd} file @file{/home/me/src/foo/foo.asd} your initialization script -could after it loads ASDF with @code{(require :asdf)} +could after it loads ASDF with @code{(require "asdf")} configure it with: @lisp @@ -612,7 +664,7 @@ @itemize @item Load ASDF itself into your Lisp image, either through - at code{(require :asdf)} or else through + at code{(require "asdf")} or else through @code{(load "/path/to/asdf.lisp")}. @item @@ -946,7 +998,7 @@ 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). +(@pxref{The defsystem grammar,,Using 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 @@ -983,32 +1035,35 @@ @xref{Common attributes of components}. - at subsection Warning about logical pathnames + at subsection Using logical pathnames @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. +We do not generally recommend the use of logical pathnames, +especially not so to newcomers to Common Lisp. +However, we do support the use of logical pathnames by old timers, +when such is their preference. To use logical pathnames, you will have to provide a pathname object as a @code{:pathname} specifier to components that use it, using such syntax as @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. Sub-components' relative pathnames, specified -using the string syntax -for names, will be properly merged with the pathnames of their parents. +You only have to specify such logical pathname +for your system or 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. 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 +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 disadvantage is that if you do not define such translations, any -system that uses logical pathnames will behave differently under +The disadvantage is that if you do not define such translations, +any system that uses logical pathnames will behave differently under asdf-output-translations than other systems you use. If you wish to use logical pathnames you will have to configure the @@ -1016,6 +1071,24 @@ ASDF currently provides no specific support for defining logical pathname translations. +Note that the reasons we do not recommend logical pathnames are that +(1) there is no portable way to set up logical pathnames before they are used, +(2) logical pathnames are limited to only portably use +a single character case, digits and hyphens. +While you can solve the first issue on your own, +describing how to do it on each of fifteen implementations supported by ASDF +is more than we can document. +As for the second issue, mind that the limitation is notably enforced on SBCL, +and that you therefore can't portably violate the limitations +but must instead define some encoding of your own and add individual mappings +to name physical pathnames that do not fit the restrictions. +This can notably be a problem when your Lisp files are part of a larger project +in which it is common to name files or directories in a way that +includes the version numbers of supported protocols, +or in which files are shared with software written +in different programming languages where conventions include the use of +underscores, dots or CamelCase in pathnames. + @subsection Serial dependencies @cindex serial dependencies @@ -1363,13 +1436,17 @@ To find and update systems, @code{find-system} funcalls each element in the @code{*system-definition-search-functions*} list, -expecting a pathname to be returned. -The resulting pathname is loaded if either of the following conditions is true: +expecting a pathname to be returned, or a system object, +from which a pathname may be extracted, and that will be registered. +The resulting pathname (if any) is loaded +if one of the following conditions is true: @itemize @item there is no system of that name in memory @item +the pathname is different from that which was previously loaded + at item the file's @code{last-modified} time exceeds the @code{last-modified} time of the system in memory @end itemize @@ -1685,18 +1762,16 @@ ()) @end lisp -A hypothetical function @code{system-dependent-dirname} +Function @code{asdf:implementation-type} (exported since 2.014.14) gives us the name of the subdirectory. All that's left is to define how to calculate the pathname of an @code{unportable-cl-source-file}. @lisp (defmethod component-pathname ((component unportable-cl-source-file)) - (let ((pathname (call-next-method)) - (name (string-downcase (system-dependent-dirname)))) - (merge-pathnames* - (make-pathname :directory (list :relative name)) - pathname))) + (merge-pathnames* + (coerce-pathname (format nil "~(~A~)/" (asdf:implementation-type))) + (call-next-method))) @end lisp The new component type is used in a @code{defsystem} form in this way: @@ -2704,7 +2779,8 @@ @defun coerce-pathname name @&key type defaults -This function takes an argument, and portably interprets it as a pathname. +This function (available starting with ASDF 2.012.11) +takes an argument, and portably interprets it as a pathname. If the argument @var{name} is a pathname or @code{nil}, it is passed through; if it's a symbol, it's interpreted as a string by downcasing it; if it's a string, it is first separated using @code{/} into substrings; @@ -3004,7 +3080,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) "2.000")} + at code{(asdf:version-satisfies (asdf:asdf-version) "2.345.67")} to check the availability of a version no earlier than required. @@ -3013,7 +3089,7 @@ When an old version of ASDF was loaded, it was very hard to upgrade ASDF in your current image without breaking everything. -Instead you have to exit the Lisp process and +Instead you had to exit the Lisp process and somehow arrange to start a new one from a simpler image. Something that can't be done from within Lisp, making automation of it difficult, @@ -3107,11 +3183,13 @@ or shallow @code{:tree} entries. Or you can fix your implementation to not be quite that slow when recursing through directories. + at underline{Update}: performance bug fixed the hard way in 2.010. @item On Windows, only LispWorks supports proper default configuration pathnames based on the Windows registry. -Other implementations make do with environment variables. +Other implementations make do with environment variables, +that you may have to define yourself if you're using an older version of Windows. Windows support is somewhat less tested than Unix support. Please help report and fix bugs. @@ -3121,10 +3199,10 @@ Previously, the pathname for a component was lazily computed when operating on a system, and you would @code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo)))) - (declare (ignorable component system)) "cl")}. + (declare (ignorable component system)) "lis")}. Now, the pathname for a component is eagerly computed when defining the system, -and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :initform "cl")))} -and use @code{:default-component-class my-cl-source-file} as argument to @code{defsystem}, +and instead you will @code{(defclass cl-source-file.lis (cl-source-file) ((type :initform "lis")))} +and use @code{:default-component-class cl-source-file.lis} as argument to @code{defsystem}, as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below. @findex source-file-type @@ -3160,7 +3238,7 @@ @itemize @item -If ASDF isn't loaded yet, then @code{(require :asdf)} +If ASDF isn't loaded yet, then @code{(require "asdf")} should load the version of ASDF that is bundled with your system. You may have it load some other version configured by the user, if you allow such configuration. @@ -3399,36 +3477,71 @@ @subsection How do I create a system definition where all the source files have a .cl extension? -First, create a new @code{cl-source-file} subclass that provides an -initform for the @code{type} slot: +Starting with ASDF 2.014.14, you may just pass +the builtin class @code{cl-source-file.cl} as +the @code{:default-component-class} argument to @code{defsystem}: @lisp -(defclass my-cl-source-file (cl-source-file) - ((type :initform "cl"))) +(defsystem my-cl-system + :default-component-class cl-source-file.cl + ...) @end lisp -To support both ASDF 1 and ASDF 2, -you may omit the above @code{type} slot definition and instead define: +Another builtin class @code{cl-source-file.lsp} is offered +for files ending in @file{.lsp}. + +If you want to use a different extension +for which ASDF doesn't provide builtin support, +or want to support versions of ASDF +earlier than 2.014.14 (but later than 2.000), +you can define a class as follows: @lisp -(defmethod source-file-type ((f my-cl-source-file) (m module)) - (declare (ignorable f m)) - "cl") +;; Prologue: make sure we're using a sane package. +(defpackage :my-asdf-extension + (:use :asdf :common-lisp) + (:export #:cl-source-file.lis)) +(in-package :my-asdf-extension) + +(defclass cl-source-file.lis (cl-source-file) + ((type :initform "lis"))) @end lisp -Then make your system use this subclass in preference to the standard -one: +Then you can use it as follows: + at lisp +(defsystem my-cl-system + :default-component-class my-asdf-extension:cl-source-file.lis + ...) + at end lisp + +Of course, if you're in the same package, e.g. in the same file, +you won't need to use the package qualifier before @code{cl-source-file.lis}. +Actually, if all you're doing is defining this class +and using it in the same file without other fancy definitions, +you might skip package complications: @lisp +(in-package :asdf) +(defclass cl-source-file.lis (cl-source-file) + ((type :initform "lis"))) (defsystem my-cl-system - :default-component-class my-cl-source-file - .... -) + :default-component-class cl-source-file.lis + ...) @end lisp -We assume that these definitions are loaded into a package that uses - at code{ASDF}. +It is possible to achieve the same effect +in a way that supports both ASDF 1 and ASDF 2, +but really, friends don't let friends use ASDF 1. +Please upgrade to ASDF 2. +In short, though: do same as above, but + at emph{before} you use the class in a @code{defsystem}, +you also define the following method: + at lisp +(defmethod source-file-type ((f cl-source-file.lis) (m module)) + (declare (ignorable f m)) + "lis") + at end lisp @node TODO list, Inspiration, FAQ, Top Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Tue Jun 7 11:07:33 2011 (r13310) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Tue Jun 7 22:23:25 2011 (r13311) @@ -1,5 +1,5 @@ ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.014: Another System Definition Facility. +;;; This is ASDF 2.016: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -19,7 +19,7 @@ ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; -;;; Copyright (c) 2001-2010 Daniel Barlow and contributors +;;; Copyright (c) 2001-2011 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -49,41 +49,28 @@ (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user) +#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) +(error "ASDF is not supported on your implementation. Please help us with it.") + #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this (eval-when (:compile-toplevel :load-toplevel :execute) - ;;; make package if it doesn't exist yet. - ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. - (unless (find-package :asdf) - (make-package :asdf :use '(:common-lisp))) ;;; Implementation-dependent tweaks ;; (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)) + :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below #+(and ecl (not ecl-bytecmp)) (require :cmp) #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*) - #+(or unix cygwin) (pushnew :asdf-unix *features*)) + #+(or unix cygwin) (pushnew :asdf-unix *features*) + ;;; make package if it doesn't exist yet. + ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. + (unless (find-package :asdf) + (make-package :asdf :use '(:common-lisp)))) (in-package :asdf) -;;; Strip out formating that is not supported on Genera. -(defmacro compatfmt (format) - #-genera format - #+genera - (let ((r '(("~@<" . "") - ("; ~@;" . "; ") - ("~3i~_" . "") - ("~@:>" . "") - ("~:>" . "")))) - (dolist (i r) - (loop :for found = (search (car i) format) :while found :do - (setf format (concatenate 'simple-string (subseq format 0 found) - (cdr i) - (subseq format (+ found (length (car i)))))))) - format)) - ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more near the end of the file. @@ -91,6 +78,26 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *asdf-version* nil) (defvar *upgraded-p* nil) + (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. + (defun find-symbol* (s p) + (find-symbol (string s) p)) + ;; Strip out formatting that is not supported on Genera. + ;; Has to be inside the eval-when to make Lispworks happy (!) + (defmacro compatfmt (format) + #-genera format + #+genera + (loop :for (unsupported . replacement) :in + '(("~@<" . "") + ("; ~@;" . "; ") + ("~3i~_" . "") + ("~@:>" . "") + ("~:>" . "")) :do + (loop :for found = (search unsupported format) :while found :do + (setf format + (concatenate 'simple-string + (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) + format) (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version ;; can help you do these changes in synch (look at the source for documentation). @@ -99,18 +106,18 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.014") - (existing-asdf (fboundp 'find-system)) + (asdf-version "2.016") + (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) (unless (and existing-asdf already-there) - (when existing-asdf + (when (and existing-asdf *asdf-verbose*) (format *trace-output* - (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") - existing-version asdf-version)) + (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") + existing-version asdf-version)) (labels ((present-symbol-p (symbol package) - (member (nth-value 1 (find-sym symbol package)) '(:internal :external))) + (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external))) (present-symbols (package) ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera (let (l) @@ -140,14 +147,12 @@ p) (t (make-package name :nicknames nicknames :use use)))))) - (find-sym (symbol package) - (find-symbol (string symbol) package)) (intern* (symbol package) (intern (string symbol) package)) (remove-symbol (symbol package) - (let ((sym (find-sym symbol package))) + (let ((sym (find-symbol* symbol package))) (when sym - (unexport sym package) + #-cormanlisp (unexport sym package) (unintern sym package) sym))) (ensure-unintern (package symbols) @@ -156,19 +161,19 @@ :for removed = (remove-symbol sym package) :when removed :do (loop :for p :in packages :do - (when (eq removed (find-sym sym p)) + (when (eq removed (find-symbol* sym p)) (unintern removed p))))) (ensure-shadow (package symbols) (shadow symbols package)) (ensure-use (package use) (dolist (used (reverse use)) (do-external-symbols (sym used) - (unless (eq sym (find-sym sym package)) + (unless (eq sym (find-symbol* sym package)) (remove-symbol sym package))) (use-package used package))) (ensure-fmakunbound (package symbols) (loop :for name :in symbols - :for sym = (find-sym name package) + :for sym = (find-symbol* name package) :when sym :do (fmakunbound sym))) (ensure-export (package export) (let ((formerly-exported-symbols nil) @@ -184,7 +189,7 @@ (loop :for user :in (package-used-by-list package) :for shadowing = (package-shadowing-symbols user) :do (loop :for new :in newly-exported-symbols - :for old = (find-sym new user) + :for old = (find-symbol* new user) :when (and old (not (member old shadowing))) :do (unintern old user))) (loop :for x :in newly-exported-symbols :do @@ -213,7 +218,7 @@ #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system #:apply-output-translations #:translate-pathname* #:resolve-location - #:compile-file*) + #:compile-file* #:source-file-type) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector @@ -225,7 +230,8 @@ #:inherit-source-registry #:process-source-registry-directive) :export (#:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous + #:system-definition-pathname #:with-system-definitions + #:search-for-system-definition #:find-component ; miscellaneous #:compile-system #:load-system #:test-system #:clear-system #:compile-op #:load-op #:load-source-op #:test-op @@ -233,12 +239,15 @@ #:feature ; sort-of operation #:version ; metaphorically sort-of an operation #:version-satisfies + #:upgrade-asdf + #:implementation-identifier #:implementation-type #:input-files #:output-files #:output-file #:perform ; operation methods #:operation-done-p #:explain #:component #:source-file #:c-source-file #:cl-source-file #:java-source-file + #:cl-source-file.cl #:cl-source-file.lsp #:static-file #:doc-file #:html-file @@ -349,7 +358,7 @@ #:subdirectories #:truenamize #:while-collecting))) - #+genera (import 'scl:boolean :asdf) + #+genera (import 'scl:boolean :asdf) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version (cons existing-version *upgraded-p*) @@ -361,7 +370,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) \"2.013\")." +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." *asdf-version*) (defvar *resolve-symlinks* t @@ -382,8 +391,6 @@ (defvar *verbose-out* nil) -(defvar *asdf-verbose* t) - (defparameter +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p)) @@ -396,6 +403,41 @@ (setf excl:*warn-on-nested-reader-conditionals* nil))) ;;;; ------------------------------------------------------------------------- +;;;; Resolve forward references + +(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 + circular-dependency-components + condition-arguments condition-form + condition-format condition-location + coerce-name) + #-cormanlisp + (ftype (function (t t) t) (setf module-components-by-name))) + +;;;; ------------------------------------------------------------------------- +;;;; Compatibility with Corman Lisp +#+cormanlisp +(progn + (deftype logical-pathname () nil) + (defun make-broadcast-stream () *error-output*) + (defun file-namestring (p) + (setf p (pathname p)) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))) + (defparameter *count* 3) + (defun dbg (&rest x) + (format *error-output* "~S~%" x))) +#+cormanlisp +(defun maybe-break () + (decf *count*) + (unless (plusp *count*) + (setf *count* 3) + (break))) + +;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities (macrolet @@ -403,8 +445,9 @@ `(defmacro ,def* (name formals &rest rest) `(progn #+(or ecl gcl) (fmakunbound ',name) - ,(when (and #+ecl (symbolp name)) - `(declaim (notinline ,name))) ; fails for setf functions on ecl + #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( + ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl + `(declaim (notinline ,name))) (,',def ,name ,formals , at rest))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) @@ -512,7 +555,8 @@ and NIL NAME, TYPE and VERSION components" (when pathname (make-pathname :name nil :type nil :version nil - :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname)) + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) :defaults pathname))) @@ -528,10 +572,10 @@ (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)) + (apply 'format *verbose-out* format-string format-args)) (defun* split-string (string &key max (separator '(#\Space #\Tab))) "Split STRING into a list of components separated by @@ -539,10 +583,10 @@ 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\")." - (block nil + (catch nil (let ((list nil) (words 0) (end (length string))) (flet ((separatorp (char) (find char separator)) - (done () (return (cons (subseq string 0 end) list)))) + (done () (throw nil (cons (subseq string 0 end) list)))) (loop :for start = (if (and max (>= words (1- max))) (done) @@ -622,10 +666,20 @@ (defun* getenv (x) (declare (ignorable x)) - #+(or abcl clisp) (ext:getenv x) + #+(or abcl clisp xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) + #+cormanlisp + (let* ((buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string x)) + (needed-size (win:getenvironmentvariable cname buffer 0)) + (buffer1 (ct:malloc (1+ needed-size)))) + (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer) + (ct:free buffer1))) #+ecl (si:getenv x) #+gcl (system:getenv x) #+genera nil @@ -635,8 +689,8 @@ (unless (ccl:%null-ptr-p value) (ccl:%get-cstring value)))) #+sbcl (sb-ext:posix-getenv x) - #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl) - (error "getenv not available on your implementation")) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) + (error "~S is not supported on your implementation" 'getenv)) (defun* directory-pathname-p (pathname) "Does PATHNAME represent a directory? @@ -712,6 +766,7 @@ '(ffi:clines "#include " "#include ")) (defun* get-uid () #+allegro (excl.osi:getuid) + #+ccl (ccl::getuid) #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") :for f = (ignore-errors (read-from-string s)) :when f :return (funcall f)) @@ -720,7 +775,7 @@ '(ffi:c-inline () () :int "getuid()" :one-liner t) '(ext::getuid)) #+sbcl (sb-unix:unix-getuid) - #-(or allegro clisp cmu ecl sbcl scl) + #-(or allegro ccl clisp cmu ecl sbcl scl) (let ((uid-string (with-output-to-string (*verbose-out*) (run-shell-command "id -ur")))) @@ -732,22 +787,21 @@ (defun* pathname-root (pathname) (make-pathname :directory '(:absolute) :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) -(defun* find-symbol* (s p) - (find-symbol (string s) p)) - (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." (etypecase p - (null nil) - (string (probe-file* (parse-namestring p))) - (pathname (unless (wild-pathname-p p) - #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) - #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p))) - '(ignore-errors (truename p))))))) + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p) + #+clisp (aif (find-symbol* '#:probe-pathname :ext) + `(ignore-errors (,it p))) + '(ignore-errors (truename p))))))) (defun* truenamize (p) "Resolve as much of a pathname as possible" @@ -788,16 +842,32 @@ path (excl:pathname-resolve-symbolic-links path))) +(defun* resolve-symlinks* (path) + (if *resolve-symlinks* + (and path (resolve-symlinks path)) + path)) + +(defun ensure-pathname-absolute (path) + (cond + ((absolute-pathname-p path) path) + ((stringp path) (ensure-pathname-absolute (pathname path))) + ((not (pathnamep path)) (error "not a valid pathname designator ~S" path)) + (t (let ((resolved (resolve-symlinks path))) + (assert (absolute-pathname-p resolved)) + resolved)))) + (defun* default-directory () (truenamize (pathname-directory-pathname *default-pathname-defaults*))) (defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) +(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*") (defparameter *wild-file* - (make-pathname :name :wild :type :wild :version :wild :directory nil)) + (make-pathname :name *wild* :type *wild* + :version (or #-(or abcl xcl) *wild*) :directory nil)) (defparameter *wild-directory* - (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)) + (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil)) (defparameter *wild-inferiors* (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil)) (defparameter *wild-path* @@ -834,27 +904,27 @@ #+scl (defun* directorize-pathname-host-device (pathname) (let ((scheme (ext:pathname-scheme pathname)) - (host (pathname-host pathname)) - (port (ext:pathname-port pathname)) - (directory (pathname-directory pathname))) + (host (pathname-host pathname)) + (port (ext:pathname-port pathname)) + (directory (pathname-directory pathname))) (flet ((not-unspecific (component) - (and (not (eq component :unspecific)) component))) + (and (not (eq component :unspecific)) component))) (cond ((or (not-unspecific port) - (and (not-unspecific host) (plusp (length host))) - (not-unspecific scheme)) - (let ((prefix "")) - (when (not-unspecific port) - (setf prefix (format nil ":~D" port))) - (when (and (not-unspecific host) (plusp (length host))) - (setf prefix (concatenate 'string host prefix))) - (setf prefix (concatenate 'string ":" prefix)) - (when (not-unspecific scheme) - (setf prefix (concatenate 'string scheme prefix))) - (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) - (t - pathname))))) + (and (not-unspecific host) (plusp (length host))) + (not-unspecific scheme)) + (let ((prefix "")) + (when (not-unspecific port) + (setf prefix (format nil ":~D" port))) + (when (and (not-unspecific host) (plusp (length host))) + (setf prefix (concatenate 'string host prefix))) + (setf prefix (concatenate 'string ":" prefix)) + (when (not-unspecific scheme) + (setf prefix (concatenate 'string scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + (t + pathname))))) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -891,6 +961,9 @@ (defgeneric* (setf component-property) (new-value component property)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defgeneric* (setf module-components-by-name) (new-value module))) + (defgeneric* version-satisfies (component version)) (defgeneric* find-component (base path) @@ -967,12 +1040,12 @@ (when *upgraded-p* (when (find-class 'module nil) (eval - `(defmethod update-instance-for-redefined-class :after + '(defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key) (declare (ignorable deleted plist)) - (when (or *asdf-verbose* *load-verbose*) + (when *asdf-verbose* (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") - m ,(asdf-version))) + m (asdf-version))) (when (member 'components-by-name added) (compute-module-components-by-name m)) (when (typep m 'system) @@ -994,44 +1067,31 @@ ;; 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 - circular-dependency-components - condition-arguments condition-form - condition-format condition-location - coerce-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)) (:report (lambda (c s) - (apply #'format s (format-control c) (format-arguments c))))) + (apply 'format s (format-control c) (format-arguments c))))) (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) (condition :initarg :condition :reader error-condition)) (:report (lambda (c s) - (format s (compatfmt "~@") - (error-name c) (error-pathname c) (error-condition c))))) + (format s (compatfmt "~@") + (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components)) (:report (lambda (c s) - (format s (compatfmt "~@") - (circular-dependency-components c))))) + (format s (compatfmt "~@") + (circular-dependency-components c))))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) - (format s (compatfmt "~@") - (duplicate-names-name c))))) + (format s (compatfmt "~@") + (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) @@ -1073,8 +1133,11 @@ ((format :initform (compatfmt "~@")))) (defclass component () - ((name :accessor component-name :initarg :name :documentation + ((name :accessor component-name :initarg :name :type string :documentation "Component name: designator for a string composed of portable pathname characters") + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! (version :accessor component-version :initarg :version) (description :accessor component-description :initarg :description) (long-description :accessor component-long-description :initarg :long-description) @@ -1154,7 +1217,7 @@ (missing-requires c) (missing-version c) (when (missing-parent c) - (component-name (missing-parent c))))) + (coerce-name (missing-parent c))))) (defmethod component-system ((component component)) (aif (component-parent component) @@ -1244,21 +1307,41 @@ (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) + (when version + (warn "Requested version ~S but component ~S has no version" version c)) (return-from version-satisfies t)) (version-satisfies (component-version c) version)) +(defun parse-version (string &optional on-error) + "Parse a version string as a series of natural integers separated by dots. +Return a (non-null) list of integers if the string is valid, NIL otherwise. +If on-error is error, warn, or designates a function of compatible signature, +the function is called with an explanation of what is wrong with the argument. +NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" + (and + (or (stringp string) + (when on-error + (funcall on-error "~S: ~S is not a string" + 'parse-version string)) nil) + (or (loop :for prev = nil :then c :for c :across string + :always (or (digit-char-p c) + (and (eql c #\.) prev (not (eql prev #\.)))) + :finally (return (and c (digit-char-p c)))) + (when on-error + (funcall on-error "~S: ~S doesn't follow asdf version numbering convention" + 'parse-version string)) nil) + (mapcar #'parse-integer (split-string string :separator ".")))) + (defmethod version-satisfies ((cver string) version) - (let ((x (mapcar #'parse-integer - (split-string cver :separator "."))) - (y (mapcar #'parse-integer - (split-string version :separator ".")))) + (let ((x (parse-version cver 'warn)) + (y (parse-version version 'warn))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) ((> (car x) (car y)) t) ((= (car x) (car y)) (bigger (cdr x) (cdr y)))))) - (and (= (car x) (car y)) + (and x y (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;; ------------------------------------------------------------------------- @@ -1284,12 +1367,21 @@ (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) +(defun* register-system (system) + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) + (unless (eq system (cdr (gethash name *defined-systems*))) + (setf (gethash name *defined-systems*) + (cons (get-universal-time) system))))) + (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 - ;; to global data structures. + ;; 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 to global data structures. (remhash (coerce-name name) *defined-systems*)) (defun* map-systems (fn) @@ -1308,16 +1400,14 @@ ;;; convention that functions in this list are prefixed SYSDEF- (defparameter *system-definition-search-functions* - '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-asdf)) -(defun* system-definition-pathname (system) +(defun* search-for-system-definition (system) (let ((system-name (coerce-name system))) - (or - (some #'(lambda (x) (funcall x system-name)) - *system-definition-search-functions*) - (let ((system-pair (system-registered-p system-name))) - (and system-pair - (system-source-file (cdr system-pair))))))) + (some #'(lambda (x) (funcall x system-name)) + (cons 'find-system-if-being-defined *system-definition-search-functions*)))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -1381,8 +1471,8 @@ (push dir to-remove)) (coerce-entry-to-directory () :report (lambda (s) - (format s (compatfmt "~@") - (ensure-directory-pathname defaults) dir)) + (format s (compatfmt "~@") + (ensure-directory-pathname defaults) dir)) (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) ;; cleanup (dolist (dir to-remove) @@ -1414,72 +1504,98 @@ ;; and we can survive and we will continue the planning ;; as if the file were very old. ;; (or should we treat the case in a different, special way?) - (or (and pathname (probe-file* pathname) (file-write-date pathname)) + (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname))) (progn (when (and pathname *asdf-verbose*) (warn (compatfmt "~@") pathname)) 0))) +(defmethod find-system ((name null) &optional (error-p t)) + (when error-p + (sysdef-error (compatfmt "~@")))) + (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) -(defun load-sysdef (name pathname) +(defvar *systems-being-defined* nil + "A hash-table of systems currently being defined keyed by name, or NIL") + +(defun* find-system-if-being-defined (name) + (when *systems-being-defined* + (gethash (coerce-name name) *systems-being-defined*))) + +(defun* call-with-system-definitions (thunk) + (if *systems-being-defined* + (funcall thunk) + (let ((*systems-being-defined* (make-hash-table :test 'equal))) + (funcall thunk)))) + +(defmacro with-system-definitions (() &body body) + `(call-with-system-definitions #'(lambda () , at body))) + +(defun* load-sysdef (name pathname) ;; Tries to load system definition with canonical NAME from PATHNAME. - (let ((package (make-temporary-package))) - (unwind-protect - (handler-bind - ((error #'(lambda (condition) - (error 'load-system-definition-error - :name name :pathname pathname - :condition condition)))) - (let ((*package* package)) - (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") - pathname package) - (load pathname))) - (delete-package package)))) + (with-system-definitions () + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) + (let ((*package* package)) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") + pathname package) + (load pathname))) + (delete-package package))))) (defmethod find-system ((name string) &optional (error-p t)) - (catch 'find-system + (with-system-definitions () (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (on-disk (system-definition-pathname name))) - (when (and on-disk - (or (not in-memory) + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))))) + (setf pathname (resolve-symlinks* pathname)) + (when (and pathname (not (absolute-pathname-p pathname))) + (setf pathname (ensure-pathname-absolute pathname)) + (when found-system + (%set-system-source-file pathname found-system))) + (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp + (system-source-file previous) pathname))) + (%set-system-source-file pathname previous) + (setf previous-time nil)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) ;; don't reload if it's already been loaded, ;; or its filestamp is in the future which means some clock is skewed ;; and trying to load might cause an infinite loop. - (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time)))) - (load-sysdef name on-disk)) + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) (let ((in-memory (system-registered-p name))) ; try again after loading from disk (cond (in-memory - (when on-disk - (setf (car in-memory) (safe-file-write-date on-disk))) + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) (cdr in-memory)) (error-p (error 'missing-component :requires name))))))) -(defun* register-system (name system) - (setf name (coerce-name name)) - (assert (equal name (component-name system))) - (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) - (setf (gethash name *defined-systems*) (cons (get-universal-time) system))) - (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) - source-file (or source-file - (if *resolve-symlinks* - (or *compile-file-truename* *load-truename*) - (or *compile-file-pathname* *load-pathname*))) requested (coerce-name requested)) (when (equal requested fallback) - (let* ((registered (cdr (gethash fallback *defined-systems*))) - (system (or registered - (apply 'make-instance 'system - :name fallback :source-file source-file keys)))) - (unless registered - (register-system fallback system)) - (throw 'find-system system)))) + (let ((registered (cdr (gethash fallback *defined-systems*)))) + (or registered + (apply 'make-instance 'system + :name fallback :source-file source-file keys))))) (defun* sysdef-find-asdf (name) ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. @@ -1523,6 +1639,10 @@ (defclass cl-source-file (source-file) ((type :initform "lisp"))) +(defclass cl-source-file.cl (cl-source-file) + ((type :initform "cl"))) +(defclass cl-source-file.lsp (cl-source-file) + ((type :initform "lsp"))) (defclass c-source-file (source-file) ((type :initform "c"))) (defclass java-source-file (source-file) @@ -1572,12 +1692,13 @@ (values filename type)) (t (split-name-type filename))) - (make-pathname :directory `(,relative , at path) :name name :type type - :defaults (or defaults *default-pathname-defaults*))))))) + (apply 'make-pathname :directory (cons relative path) :name name :type type + (when defaults `(:defaults ,defaults)))))))) (defun* merge-component-name-type (name &key type defaults) ;; For backwards compatibility only, for people using internals. - ;; Will be removed in a future release, e.g. 2.014. + ;; Will be removed in a future release, e.g. 2.016. + (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") (coerce-pathname name :type type :defaults defaults)) (defmethod component-relative-pathname ((component component)) @@ -1593,15 +1714,14 @@ ;;; one of these is instantiated whenever #'operate is called (defclass operation () - ( - ;; as of danb's 2003-03-16 commit e0d02781, :force can be: - ;; T to force the inside of existing system, + (;; as of danb's 2003-03-16 commit e0d02781, :force can be: + ;; T to force the inside of the specified system, ;; but not recurse to other systems we depend on. ;; :ALL (or any other atom) to force all systems ;; including other systems we depend on. ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) ;; to force systems named in a given list - ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out. + ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 (forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) @@ -1643,13 +1763,13 @@ (not (eql c dep-c))) (when (eql force-p t) (setf (getf args :force) nil)) - (apply #'make-instance dep-o + (apply 'make-instance dep-o :parent o :original-initargs args args)) ((subtypep (type-of o) dep-o) o) (t - (apply #'make-instance dep-o + (apply 'make-instance dep-o :parent o :original-initargs args args))))) @@ -1681,11 +1801,13 @@ (gethash node (operation-visiting-nodes (operation-ancestor o))))) (defmethod component-depends-on ((op-spec symbol) (c component)) + ;; Note: we go from op-spec to operation via make-instance + ;; to allow for specialization through defmethod's, even though + ;; it's a detour in the default case below. (component-depends-on (make-instance op-spec) c)) (defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (class-name (class-of o)) - (component-in-order-to c)))) + (cdr (assoc (type-of o) (component-in-order-to c)))) (defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) @@ -1802,13 +1924,13 @@ required-op required-c required-v)) (retry () :report (lambda (s) - (format s "~@" required-c)) + (format s "~@" required-c)) :test (lambda (c) - (or (null c) - (and (typep c 'missing-dependency) - (equalp (missing-requires c) - required-c)))))))) + (or (null c) + (and (typep c 'missing-dependency) + (equalp (missing-requires c) + required-c)))))))) (defun* do-dep (operation c collect op dep) ;; type of arguments uncertain: @@ -1855,11 +1977,11 @@ (funcall collect x)) (defmethod do-traverse ((operation operation) (c component) collect) - (let ((flag nil)) ;; return value: must we rebuild this and its dependencies? + (let ((*forcing* *forcing*) + (flag nil)) ;; return value: must we rebuild this and its dependencies? (labels ((update-flag (x) - (when x - (setf flag t))) + (orf flag x)) (dep (op comp) (update-flag (do-dep operation c collect op comp)))) ;; Have we been visited yet? If so, just process the result. @@ -1873,6 +1995,13 @@ (setf (visiting-component operation c) t) (unwind-protect (progn + (let ((f (operation-forced + (operation-ancestor operation)))) + (when (and f (or (not (consp f)) ;; T or :ALL + (and (typep c 'system) ;; list of names of systems to force + (member (component-name c) f + :test #'string=)))) + (setf *forcing* t))) ;; first we check and do all the dependencies for the module. ;; Operations planned in this loop will show up ;; in the results, and are consumed below. @@ -1912,22 +2041,13 @@ :try-next) (not at-least-one)) (error error))))))) - (update-flag - (or - *forcing* - (not (operation-done-p operation c)) + (update-flag (or *forcing* (not (operation-done-p operation c)))) ;; For sub-operations, check whether ;; the original ancestor operation was forced, ;; or names us amongst an explicit list of things to force... ;; except that this check doesn't distinguish ;; between all the things with a given name. Sigh. ;; BROKEN! - (let ((f (operation-forced - (operation-ancestor operation)))) - (and f (or (not (consp f)) ;; T or :ALL - (and (typep c 'system) ;; list of names of systems to force - (member (component-name c) f - :test #'string=))))))) (when flag (let ((do-first (cdr (assoc (class-name (class-of operation)) (component-do-first c))))) @@ -1956,12 +2076,7 @@ (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 @@ -1979,11 +2094,12 @@ nil) (defmethod explain ((operation operation) (component component)) - (asdf-message "~&;;; ~A~%" (operation-description operation component))) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") + (operation-description operation component))) (defmethod operation-description (operation component) - (format nil (compatfmt "~@<~A on component ~S~@:>") - (class-of operation) (component-find-path component))) + (format nil (compatfmt "~@<~A on ~A~@:>") + (class-of operation) component)) ;;;; ------------------------------------------------------------------------- ;;;; compile-op @@ -2030,13 +2146,8 @@ (multiple-value-bind (output warnings-p failure-p) (apply *compile-op-compile-file-function* source-file :output-file output-file (compile-op-flags operation)) - (when warnings-p - (case (operation-on-warnings operation) - (:warn (warn - (compatfmt "~@") - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil))) + (unless output + (error 'compile-error :component c :operation operation)) (when failure-p (case (operation-on-failure operation) (:warn (warn @@ -2044,8 +2155,13 @@ operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) - (unless output - (error 'compile-error :component c :operation operation))))) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + (compatfmt "~@") + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil)))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) (declare (ignorable operation)) @@ -2067,7 +2183,12 @@ (defmethod operation-description ((operation compile-op) component) (declare (ignorable operation)) - (format nil "compiling component ~S" (component-find-path component))) + (format nil (compatfmt "~@") component)) + +(defmethod operation-description ((operation compile-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) + ;;;; ------------------------------------------------------------------------- ;;;; load-op @@ -2080,6 +2201,7 @@ (map () #'load (input-files o c))) (defmethod perform-with-restarts (operation component) + ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default. (perform operation component)) (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) @@ -2094,7 +2216,7 @@ (setf state :success)) (:failed-load (setf state :recompiled) - (perform (make-instance 'compile-op) c)) + (perform (make-sub-operation c o c 'compile-op) c)) (t (with-simple-restart (try-recompiling "Recompile ~a and try loading it again" @@ -2142,9 +2264,18 @@ (defmethod operation-description ((operation load-op) component) (declare (ignorable operation)) - (format nil (compatfmt "~@") - (component-find-path component))) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-op) (component cl-source-file)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) +(defmethod operation-description ((operation load-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) ;;;; ------------------------------------------------------------------------- ;;;; load-source-op @@ -2166,16 +2297,12 @@ (declare (ignorable operation c)) nil) -;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) (declare (ignorable o)) - (let ((what-would-load-op-do (cdr (assoc 'load-op - (component-in-order-to c))))) - (mapcar #'(lambda (dep) - (if (eq (car dep) 'load-op) - (cons 'load-source-op (cdr dep)) - dep)) - what-would-load-op-do))) + (loop :with what-would-load-op-do = (component-depends-on 'load-op c) + :for (op . co) :in what-would-load-op-do + :when (eq op 'load-op) :collect (cons 'load-source-op co))) (defmethod operation-done-p ((o load-source-op) (c source-file)) (declare (ignorable o)) @@ -2186,8 +2313,12 @@ (defmethod operation-description ((operation load-source-op) component) (declare (ignorable operation)) - (format nil (compatfmt "~@") - (component-find-path component))) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-source-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) ;;;; ------------------------------------------------------------------------- @@ -2213,48 +2344,93 @@ ;;;; Invoking Operations (defgeneric* operate (operation-class system &key &allow-other-keys)) +(defgeneric* perform-plan (plan &key)) + +;;;; Try to upgrade of ASDF. If a different version was used, return T. +;;;; We need do that before we operate on anything that depends on ASDF. +(defun* upgrade-asdf () + (let ((version (asdf:asdf-version))) + (handler-bind (((or style-warning warning) #'muffle-warning)) + (operate 'load-op :asdf :verbose nil)) + (let ((new-version (asdf:asdf-version))) + (block nil + (cond + ((equal version new-version) + (return nil)) + ((version-satisfies new-version version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + version new-version)) + ((version-satisfies version new-version) + (warn (compatfmt "~&~@~%") + version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + version new-version))) + (let ((asdf (find-system :asdf))) + ;; invalidate all systems but ASDF itself + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + t))))) + +(defmethod perform-plan ((steps list) &key) + (let ((*package* *package*) + (*readtable* *readtable*)) + (with-compilation-unit () + (loop :for (op . component) :in steps :do + (loop + (restart-case + (progn + (perform-with-restarts op component) + (return)) + (retry () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description op component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description op component))) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return)))))))) (defmethod operate (operation-class system &rest args &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force &allow-other-keys) (declare (ignore force)) - (let* ((*package* *package*) - (*readtable* *readtable*) - (op (apply #'make-instance operation-class - :original-initargs args - args)) - (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system)))) - (unless (version-satisfies system version) - (error 'missing-component-of-version :requires system :version version)) - (let ((steps (traverse op system))) - (with-compilation-unit () - (loop :for (op . component) :in steps :do - (loop - (restart-case - (progn - (perform-with-restarts op component) - (return)) - (retry () - :report - (lambda (s) - (format s (compatfmt "~@") - (operation-description op component)))) - (accept () - :report - (lambda (s) - (format s (compatfmt "~@") - (operation-description op component))) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))) - (values op steps)))) + (with-system-definitions () + (let* ((op (apply 'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) + (system (etypecase system + (system system) + ((or string symbol) (find-system system))))) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + (let ((steps (traverse op system))) + (when (and (not (equal '("asdf") (component-find-path system))) + (find '("asdf") (mapcar 'cdr steps) + :test 'equal :key 'component-find-path) + (upgrade-asdf)) + ;; If we needed to upgrade ASDF to achieve our goal, + ;; then do it specially as the first thing, then + ;; invalidate all existing system + ;; retry the whole thing with the new OPERATE function, + ;; which on some implementations + ;; has a new symbol shadowing the current one. + (return-from operate + (apply (find-symbol* 'operate :asdf) operation-class system args))) + (perform-plan steps) + (values op steps))))) (defun* oos (operation-class system &rest args &key force verbose version &allow-other-keys) (declare (ignore force verbose version)) - (apply #'operate operation-class system args)) + (apply 'operate operation-class system args)) (let ((operate-docstring "Operate does three things: @@ -2281,12 +2457,11 @@ (setf (documentation 'operate 'function) operate-docstring)) -(defun* load-system (system &rest args &key force verbose version - &allow-other-keys) - "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for -details." +(defun* load-system (system &rest args &key force verbose version &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. +See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'load-op system args) + (apply 'operate 'load-op system args) t) (defun* compile-system (system &rest args &key force verbose version @@ -2294,7 +2469,7 @@ "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'compile-op system args) + (apply 'operate 'compile-op system args) t) (defun* test-system (system &rest args &key force verbose version @@ -2302,17 +2477,14 @@ "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'test-op system args) + (apply 'operate 'test-op system args) t) ;;;; ------------------------------------------------------------------------- ;;;; Defsystem (defun* load-pathname () - (let ((pn (or *load-pathname* *compile-file-pathname*))) - (if *resolve-symlinks* - (and pn (resolve-symlinks pn)) - pn))) + (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) (defun* determine-system-pathname (pathname pathname-supplied-p) ;; The defsystem macro calls us to determine @@ -2328,45 +2500,18 @@ directory-pathname (default-directory)))) -(defmacro defsystem (name &body options) - (setf name (coerce-name name)) - (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) - defsystem-depends-on &allow-other-keys) - options - (let ((component-options (remove-keys '(:class) options))) - `(progn - ;; system must be registered before we parse the body, otherwise - ;; we recur when trying to find an existing system of the same name - ;; to reuse options (e.g. pathname) from - ,@(loop :for system :in defsystem-depends-on - :collect `(load-system ',(coerce-name system))) - (let ((s (system-registered-p ',name))) - (cond ((and s (eq (type-of (cdr s)) ',class)) - (setf (car s) (get-universal-time))) - (s - (change-class (cdr s) ',class)) - (t - (register-system (quote ,name) - (make-instance ',class :name ',name)))) - (%set-system-source-file (load-pathname) - (cdr (system-registered-p ',name)))) - (parse-component-form - nil (list* - :module (coerce-name ',name) - :pathname - ,(determine-system-pathname pathname pathname-arg-p) - ',component-options)))))) - (defun* class-for-type (parent type) (or (loop :for symbol :in (list type (find-symbol* type *package*) (find-symbol* type :asdf)) :for class = (and symbol (find-class symbol nil)) - :when (and class (subtypep class 'component)) + :when (and class + (#-cormanlisp subtypep #+cormanlisp cl::subclassp + class (find-class 'component))) :return class) (and (eq type :file) - (or (module-default-component-class parent) + (or (and parent (module-default-component-class parent)) (find-class *default-component-class*))) (sysdef-error "don't recognize component type ~A" type))) @@ -2458,6 +2603,7 @@ perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to + (version nil versionp) ;; list ends &allow-other-keys) options (declare (ignorable perform explain output-files operation-done-p)) @@ -2471,6 +2617,11 @@ (class-for-type parent type)))) (error 'duplicate-names :name name)) + (when versionp + (unless (parse-version version nil) + (warn (compatfmt "~@") + version name parent))) + (let* ((other-args (remove-keys '(components pathname default-component-class perform explain output-files operation-done-p @@ -2484,7 +2635,7 @@ (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) - (apply #'reinitialize-instance ret + (apply 'reinitialize-instance ret :name (coerce-name name) :pathname pathname :parent parent @@ -2517,6 +2668,40 @@ (%refresh-component-inline-methods ret rest) ret))) +(defun* do-defsystem (name &rest options + &key (pathname nil pathname-arg-p) (class 'system) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in a special variable *systems-being-defined*. + (with-system-definitions () + (let* ((name (coerce-name name)) + (registered (system-registered-p name)) + (system (cdr (or registered + (register-system (make-instance 'system :name name))))) + (component-options (remove-keys '(:class) options))) + (%set-system-source-file (load-pathname) system) + (setf (gethash name *systems-being-defined*) system) + (when registered + (setf (car registered) (get-universal-time))) + (map () 'load-system defsystem-depends-on) + ;; We change-class (when necessary) AFTER we load the defsystem-dep's + ;; since the class might not be defined as part of those. + (let ((class (class-for-type nil class))) + (unless (eq (type-of system) class) + (change-class system class))) + (parse-component-form + nil (list* + :module name + :pathname (determine-system-pathname pathname pathname-arg-p) + component-options))))) + +(defmacro defsystem (name &body options) + `(apply 'do-defsystem ',name ',options)) + ;;;; --------------------------------------------------------------------------- ;;;; run-shell-command ;;;; @@ -2534,7 +2719,7 @@ "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." - (let ((command (apply #'format nil control-string args))) + (let ((command (apply 'format nil control-string args))) (asdf-message "; $ ~A~%" command) #+abcl @@ -2552,8 +2737,8 @@ (asdf-message "~{~&; ~a~%~}~%" stdout) exit-code) - #+clisp ;XXX not exactly *verbose-out*, I know - (or (ext:run-shell-command command :output :terminal :wait t) 0) + #+clisp ;XXX not exactly *verbose-out*, I know + (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0) #+clozure (nth-value 1 @@ -2578,7 +2763,7 @@ #+sbcl (sb-ext:process-exit-code - (apply #'sb-ext:run-program + (apply 'sb-ext:run-program #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) :input nil :output *verbose-out* @@ -2591,12 +2776,28 @@ (list "-c" command) :input nil :output *verbose-out*)) - #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) + #+xcl + (ext:run-shell-command command) + + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl) (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) ;;;; --------------------------------------------------------------------------- ;;;; system-relative-pathname +(defun* system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x)) + (defmethod system-source-file ((system-name string)) (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) @@ -2644,10 +2845,10 @@ (:ccl :clozure) (:corman :cormanlisp) (:lw :lispworks) - :clisp :cmu :ecl :gcl :sbcl :scl :symbolics)) + :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl)) (defparameter *os-features* - '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows + '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows (:solaris :sunos) (:linux :linux-target) ;; for GCL at least, must appear before :bsd. (:macosx :darwin :darwin-target :apple) @@ -2656,54 +2857,48 @@ :genera)) (defparameter *architecture-features* - '((:amd64 :x86-64 :x86_64 :x8664-target) + '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386) (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) - :hppa64 - :hppa - (:ppc64 :ppc64-target) - (:ppc32 :ppc32-target :ppc :powerpc) - :sparc64 - (:sparc32 :sparc) + :hppa64 :hppa + (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc) + :sparc64 (:sparc32 :sparc) (:arm :arm-target) (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7) + :mipsel :mipseb :mips + :alpha :imach)) (defun* lisp-version-string () (let ((s (lisp-implementation-version))) - (declare (ignorable s)) - #+allegro (format nil - "~A~A~A~A" - excl::*common-lisp-version-number* - ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox - (if (eq excl:*current-case-mode* - :case-sensitive-lower) "M" "A") - ;; Note if not using International ACL - ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm - (excl:ics-target-case - (:-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)) ; strip build information (date, etc.) - #+clozure (format nil "~d.~d-f~d" ; shorten for windows - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version* - (logand ccl::fasl-version #xFF)) - #+cmu (substitute #\- #\/ s) - #+ecl (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (when (>= (length vcs-id) 8) - (subseq vcs-id 0 8)))) - #+gcl (subseq s (1+ (position #\space s))) - #+genera (multiple-value-bind (major minor) (sct:get-system-version "System") - (format nil "~D.~D" major minor)) - #+lispworks (format nil "~A~@[~A~]" s - (when (member :lispworks-64bit *features*) "-64bit")) - ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version - #+mcl (subseq s 8) ; strip the leading "Version " - #+(or cormanlisp sbcl scl) s - #-(or allegro armedbear clisp clozure cmu cormanlisp - ecl gcl genera lispworks mcl sbcl scl) s)) + (or + #+allegro (format nil + "~A~A~A" + excl::*common-lisp-version-number* + ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox + (if (eq excl:*current-case-mode* + :case-sensitive-lower) "M" "A") + ;; Note if not using International ACL + ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm + (excl:ics-target-case + (:-ics "8") + (:+ics ""))) ; redundant? (if (member :64bit *features*) "-64bit" "")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) + #+clozure (format nil "~d.~d-f~d" ; shorten for windows + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand ccl::fasl-version #xFF)) + #+cmu (substitute #\- #\/ s) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))) + #+gcl (subseq s (1+ (position #\space s))) + #+genera (multiple-value-bind (major minor) (sct:get-system-version "System") + (format nil "~D.~D" major minor)) + ;; #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit") #+mcl (subseq s 8) ; strip the leading "Version " + ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version + s))) (defun* first-feature (features) (labels @@ -2728,7 +2923,7 @@ (labels ((maybe-warn (value fstring &rest args) (cond (value) - (t (apply #'warn fstring args) + (t (apply 'warn fstring args) "unknown")))) (let ((lisp (maybe-warn (implementation-type) (compatfmt "~@") @@ -2753,8 +2948,19 @@ #+asdf-unix #\: #-asdf-unix #\;) +;; Note: ASDF may expect user-homedir-pathname to provide the pathname of +;; the current user's home directory, while MCL by default provides the +;; directory from which MCL was started. +;; See http://code.google.com/p/mcl/wiki/Portability +#.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl + `(defun current-user-homedir-pathname () + ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))"))) + (defun* user-homedir () - (truenamize (pathname-directory-pathname (user-homedir-pathname)))) + (truenamize + (pathname-directory-pathname + #+mcl (current-user-homedir-pathname) + #-mcl (user-homedir-pathname)))) (defun* try-directory-subpath (x sub &key type) (let* ((p (and x (ensure-directory-pathname x))) @@ -2763,29 +2969,34 @@ (ts (and sp (probe-file* sp)))) (and ts (values sp ts)))) (defun* user-configuration-directories () - (remove-if - #'null - (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) - `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") - ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") - :collect (try dir "common-lisp/")) - #+asdf-windows - ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") - ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - ,(try (getenv "APPDATA") "common-lisp/config/")) - ,(try (user-homedir) ".config/common-lisp/"))))) + (let ((dirs + (flet ((try (x sub) (try-directory-subpath x sub))) + `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") + ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") + :for dir :in (split-string dirs :separator ":") + :collect (try dir "common-lisp/")) + #+asdf-windows + ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + "common-lisp/config/") + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + ,(try (or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp/config/")) + ,(try (user-homedir) ".config/common-lisp/"))))) + (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) (defun* system-configuration-directories () (remove-if #'null - (append - #+asdf-windows - (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) - `(,@`(#+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/")))) - #+asdf-unix - (list #p"/etc/common-lisp/")))) + `(#+asdf-windows + ,(flet ((try (x sub) (try-directory-subpath x sub))) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData + (try (or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (try (getenv "ALLUSERSPROFILE") "Application Data/")) + "common-lisp/config/")) + #+asdf-unix #p"/etc/common-lisp/"))) + (defun* in-first-directory (dirs x) (loop :for dir :in dirs :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) @@ -2845,7 +3056,7 @@ (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) (error (compatfmt "~@~%") - description forms)) + description forms)) (funcall validator (car forms) :location file))) (defun* hidden-file-p (pathname) @@ -2857,7 +3068,8 @@ #+clozure '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmu scl) '(:follow-links nil :truenamep nil) - #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil)))))) + #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl) + '(:resolve-symlinks nil)))))) (defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will @@ -2903,7 +3115,11 @@ (or (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) #+asdf-windows - (try (getenv "APPDATA") "common-lisp" "cache" :implementation) + (try (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA") + #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp" "cache" :implementation) '(:home ".cache" "common-lisp" :implementation)))) (defvar *system-cache* ;; No good default, plus there's a security problem @@ -3002,7 +3218,10 @@ :default-directory) :directory t :wilden nil)) ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) - ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) + ((eql :system-cache) + (warn "Using the :system-cache is deprecated. ~%~ +Please remove it from your ASDF configuration") + (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) (s (if (and wilden (not (pathnamep x))) (wilden r) @@ -3101,7 +3320,7 @@ ((equal "" s) (when inherit (error (compatfmt "~@") - string)) + string)) (setf inherit t) (push :inherit-configuration directives)) (t @@ -3110,7 +3329,7 @@ (when (> start end) (when source (error (compatfmt "~@") - string)) + string)) (unless inherit (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) @@ -3128,8 +3347,9 @@ ;; so we must disable translations for implementation paths. #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ()))) - #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system - #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system + ;; The below two are not needed: no precompiled ASDF system there + ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) + ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: @@ -3142,7 +3362,7 @@ (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) (defun* user-output-translations-pathname () - (in-user-configuration-directory *output-translations-file* )) + (in-user-configuration-directory *output-translations-file*)) (defun* system-output-translations-pathname () (in-system-configuration-directory *output-translations-file*)) (defun* user-output-translations-directory-pathname () @@ -3216,8 +3436,9 @@ ((eq dst t) (funcall collect (list trusrc t))) (t - (let* ((trudst (make-pathname - :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) + (let* ((trudst (if dst + (resolve-location dst :directory t :wilden t) + trusrc)) (wilddst (merge-pathnames* *wild-file* trudst))) (funcall collect (list wilddst t)) (funcall collect (list trusrc trudst))))))))))) @@ -3271,6 +3492,7 @@ (defun* apply-output-translations (path) (etypecase path + #+cormanlisp (t (truenamize path)) (logical-pathname path) ((or pathname string) @@ -3300,7 +3522,8 @@ t)) (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) - (or output-file + (if (absolute-pathname-p output-file) + (apply 'compile-file-pathname (lispize-pathname input-file) keys) (apply-output-translations (apply 'compile-file-pathname (truenamize (lispize-pathname input-file)) @@ -3316,7 +3539,7 @@ (delete-file x))) (defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) - (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys))) + (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys)) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) @@ -3383,7 +3606,7 @@ (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (mapped-files (if map-all-source-files *wild-file* - (make-pathname :name :wild :version :wild :type fasl-type))) + (make-pathname :type fasl-type :defaults *wild-file*))) (destination-directory (if centralize-lisp-binaries `(,default-toplevel-directory @@ -3417,8 +3640,7 @@ :do (write-char (code-char code) out)))) (defun* read-little-endian (s &optional (bytes 4)) - (loop - :for i :from 0 :below bytes + (loop :for i :from 0 :below bytes :sum (ash (read-byte s) (* 8 i)))) (defun* parse-file-location-info (s) @@ -3485,64 +3707,62 @@ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" - "debian")) ;; debian often build stuff under the debian directory... BAD. + "debian")) ;; debian often builds stuff under the debian directory... BAD. (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") - -(defun* source-registry () - (car *source-registry*)) - -(defun* (setf source-registry) (new-value) - (setf *source-registry* (list new-value)) - new-value) +(defvar *source-registry* nil + "Either NIL (for uninitialized), or an equal hash-table, mapping +system names to pathnames of .asd files") (defun* source-registry-initialized-p () - (and *source-registry* t)) + (typep *source-registry* 'hash-table)) (defun* clear-source-registry () "Undoes any initialization of the source registry. You might want to call that before you dump an image that would be resumed with a different configuration, so the configuration would be re-read then." - (setf *source-registry* '()) + (setf *source-registry* nil) (values)) (defparameter *wild-asd* - (make-pathname :directory nil :name :wild :type "asd" :version :newest)) + (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) -(defun directory-has-asd-files-p (directory) +(defun directory-asd-files (directory) (ignore-errors - (and (directory* (merge-pathnames* *wild-asd* directory)) t))) + (directory* (merge-pathnames* *wild-asd* directory)))) (defun subdirectories (directory) (let* ((directory (ensure-directory-pathname directory)) - #-(or cormanlisp genera) + #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro lispworks scl) + #-(or abcl allegro cmu lispworks scl xcl) *wild-directory* - #+(or abcl allegro lispworks scl) "*.*" + #+(or abcl allegro cmu lispworks scl xcl) "*.*" directory)) (dirs - #-(or cormanlisp genera) + #-(or abcl cormanlisp genera xcl) (ignore-errors (directory* wild . #.(or #+clozure '(:directories t :files nil) #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) #+genera (fs:directory-list directory)) - #+(or abcl allegro genera lispworks scl) - (dirs (remove-if-not #+abcl #'extensions:probe-directory - #+allegro #'excl:probe-directory - #+lispworks #'lw:file-directory-p - #+genera #'(lambda (x) (getf (cdr x) :directory)) - #-(or abcl allegro genera lispworks) #'directory-pathname-p - dirs)) - #+genera - (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs))) + #+(or abcl allegro cmu genera lispworks scl xcl) + (dirs (loop :for x :in dirs + :for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu scl) (directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + :when d :collect #+(or abcl allegro xcl) d + #+genera (ensure-directory-pathname (first x)) + #+(or cmu lispworks scl) x))) dirs)) +(defun collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + (defun collect-sub*directories (directory collectp recursep collector) (when (funcall collectp directory) (funcall collector directory)) @@ -3550,15 +3770,15 @@ (when (funcall recursep subdir) (collect-sub*directories subdir collectp recursep collector)))) -(defun collect-sub*directories-with-asd +(defun collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect) (collect-sub*directories directory - #'directory-has-asd-files-p + (constantly t) #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) - collect)) + #'(lambda (dir) (collect-asds-in-directory dir collect)))) (defun* validate-source-registry-directive (directive) (or (member directive '(:default-registry)) @@ -3603,17 +3823,21 @@ :with end = (length string) :for pos = (position *inter-directory-separator* string :start start) :do (let ((s (subseq string start (or pos end)))) - (cond - ((equal "" s) ; empty element: inherit - (when inherit - (error (compatfmt "~@") - string)) - (setf inherit t) - (push ':inherit-configuration directives)) - ((ends-with s "//") - (push `(:tree ,(subseq s 0 (1- (length s)))) directives)) - (t - (push `(:directory ,s) directives))) + (flet ((check (dir) + (unless (absolute-pathname-p dir) + (error (compatfmt "~@") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@") + string)) + (setf inherit t) + (push ':inherit-configuration directives)) + ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix? + (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) + (t + (push `(:directory ,(check s)) directives)))) (cond (pos (setf start (1+ pos))) @@ -3624,8 +3848,8 @@ (defun* register-asd-directory (directory &key recurse exclude collect) (if (not recurse) - (funcall collect directory) - (collect-sub*directories-with-asd + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files directory :exclude exclude :collect collect))) (defparameter *default-source-registries* @@ -3645,30 +3869,27 @@ :inherit-configuration #+cmu (:tree #p"modules:"))) (defun* default-source-registry () - (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) + (flet ((try (x sub) (try-directory-subpath x sub))) `(:source-registry - #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) + #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/")) (:directory ,(default-directory)) - ,@(let* - #+asdf-unix - ((datahome - (or (getenv "XDG_DATA_HOME") - (try (user-homedir) ".local/share/"))) - (datadirs - (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) - (dirs (cons datahome (split-string datadirs :separator ":")))) - #+asdf-windows - ((datahome (getenv "APPDATA")) - (datadir - #+lispworks (sys:get-folder-path :local-appdata) - #-lispworks (try (getenv "ALLUSERSPROFILE") - "Application Data")) - (dirs (list datahome datadir))) - #-(or asdf-unix asdf-windows) - ((dirs ())) - (loop :for dir :in dirs - :collect `(:directory ,(try dir "common-lisp/systems/")) - :collect `(:tree ,(try dir "common-lisp/source/")))) + ,@(loop :for dir :in + `(#+asdf-unix + ,@`(,(or (getenv "XDG_DATA_HOME") + (try (user-homedir) ".local/share/")) + ,@(split-string (or (getenv "XDG_DATA_DIRS") + "/usr/local/share:/usr/share") + :separator ":")) + #+asdf-windows + ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + ,(or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + ,(or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (try (getenv "ALLUSERSPROFILE") "Application Data/")))) + :collect `(:directory ,(try dir "common-lisp/systems/")) + :collect `(:tree ,(try dir "common-lisp/source/"))) :inherit-configuration))) (defun* user-source-registry () (in-user-configuration-directory *source-registry-file*)) @@ -3757,19 +3978,34 @@ ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. -(defun* compute-source-registry (&optional parameter) - (while-collecting (collect) - (dolist (entry (flatten-source-registry parameter)) - (destructuring-bind (directory &key recurse exclude) entry +(defun* compute-source-registry (&optional parameter (registry *source-registry*)) + (dolist (entry (flatten-source-registry parameter)) + (destructuring-bind (directory &key recurse exclude) entry + (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates (register-asd-directory - directory - :recurse recurse :exclude exclude :collect #'collect))))) + directory :recurse recurse :exclude exclude :collect + #'(lambda (asd) + (let ((name (pathname-name asd))) + (cond + ((gethash name registry) ; already shadowed by something else + nil) + ((gethash name h) ; conflict at current level + (when *asdf-verbose* + (warn (compatfmt "~@") + directory recurse name (gethash name h) asd))) + (t + (setf (gethash name registry) asd) + (setf (gethash name h) asd)))))) + h))) + (values)) (defvar *source-registry-parameter* nil) (defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) - (setf *source-registry-parameter* parameter - (source-registry) (compute-source-registry parameter))) + (setf *source-registry-parameter* parameter) + (setf *source-registry* (make-hash-table :test 'equal)) + (compute-source-registry parameter)) ;; Checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in @@ -3780,24 +4016,60 @@ ;; 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 parameter))) + (unless (source-registry-initialized-p) + (initialize-source-registry parameter)) + (values)) (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)) + (values (gethash (coerce-name system) *source-registry*))) (defun* clear-configuration () (clear-source-registry) (clear-output-translations)) + +;;; ECL support for COMPILE-OP / LOAD-OP +;;; +;;; In ECL, these operations produce both FASL files and the +;;; object files that they are built from. Having both of them allows +;;; us to later on reuse the object files for bundles, libraries, +;;; standalone executables, etc. +;;; +;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes +;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. +;;; +#+ecl +(progn + (setf *compile-op-compile-file-function* + (lambda (input-file &rest keys &key output-file &allow-other-keys) + (declare (ignore output-file)) + (multiple-value-bind (object-file flags1 flags2) + (apply 'compile-file* input-file :system-p t keys) + (values (and object-file + (c::build-fasl (compile-file-pathname object-file :type :fasl) + :lisp-files (list object-file)) + object-file) + flags1 + flags2)))) + + (defmethod output-files ((operation compile-op) (c cl-source-file)) + (declare (ignorable operation)) + (let ((p (lispize-pathname (component-pathname c)))) + (list (compile-file-pathname p :type :object) + (compile-file-pathname p :type :fasl)))) + + (defmethod perform ((o load-op) (c cl-source-file)) + (map () #'load + (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (compile-file-pathname (lispize-pathname i)))))) + ;;;; ----------------------------------------------------------------- ;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL ;;;; +(defvar *require-asdf-operator* 'load-op) + (defun* module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning) @@ -3806,9 +4078,10 @@ (format *error-output* (compatfmt "~@~%") name e)))) (let ((*verbose-out* (make-broadcast-stream)) - (system (find-system (string-downcase name) nil))) + (system (find-system (string-downcase name) nil))) (when system - (load-system system))))) + (operate *require-asdf-operator* system :verbose nil) + t)))) #+(or abcl clisp clozure cmu ecl sbcl) (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) From mevenson at common-lisp.net Wed Jun 8 15:28:13 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 08 Jun 2011 08:28:13 -0700 Subject: [armedbear-cvs] r13312 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Wed Jun 8 08:28:11 2011 New Revision: 13312 Log: Renam RUN-MATCHING to DO-MATCHING improving output. Modified: trunk/abcl/test/lisp/abcl/package.lisp Modified: trunk/abcl/test/lisp/abcl/package.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/package.lisp Tue Jun 7 22:23:25 2011 (r13311) +++ trunk/abcl/test/lisp/abcl/package.lisp Wed Jun 8 08:28:11 2011 (r13312) @@ -2,8 +2,10 @@ (:use #:cl #:abcl-rt) (:nicknames "ABCL-TEST-LISP" "ABCL-TEST") (:export - #:run #:run-matching - #:do-test #:do-tests)) + #:run + #:do-matching #:run-matching + #:do-test + #:do-tests)) (in-package #:abcl.test.lisp) (defparameter *abcl-test-directory* @@ -18,21 +20,26 @@ (let ((*default-pathname-defaults* *abcl-test-directory*)) (do-tests))) +;;; XXX move this into test-utilities.lisp? (defvar *last-run-matching* "url-pathname") -;;; XXX move this into test-utilities.lisp? -(defun run-matching (&optional (match *last-run-matching*)) +(defun do-matching (&optional (match *last-run-matching*)) "Run all tests in suite whose symbol contains MATCH in a case-insensitive manner." (setf *last-run-matching* match) (let* ((matching (string-upcase match)) - (tests - (remove-if-not - (lambda (name) (search matching name)) - (mapcar (lambda (entry) - (symbol-name (abcl-rt::name entry))) - (rest abcl-rt::*entries*))))) - (dolist (test tests) - (do-test (intern test :abcl.test.lisp))))) + (count 0)) + (mapcar (lambda (entry) + (if (search matching (symbol-name (abcl-rt::name entry))) + (setf (abcl-rt::pend entry) t + count (1+ count)) + (setf (abcl-rt::pend entry) nil))) + (rest abcl-rt::*entries*)) + (format t "Performing ~A tests matching '~A'.~%" count matching) + (abcl-rt::do-entries t))) + +;;; Deprecated +(setf (symbol-function 'run-matching) #'do-matching) + From mevenson at common-lisp.net Wed Jun 8 16:03:16 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 08 Jun 2011 09:03:16 -0700 Subject: [armedbear-cvs] r13313 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Wed Jun 8 09:03:16 2011 New Revision: 13313 Log: Use directory derived from java.io.File.createTempFile() to write tests. *TMP-DIRECTORY* now names the location used by the JAR-PATHNAME tests to create and load tests. Move the forms to compile into special variables. Deleted: trunk/abcl/test/lisp/abcl/bar.lisp trunk/abcl/test/lisp/abcl/eek.lisp trunk/abcl/test/lisp/abcl/foo.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Wed Jun 8 08:28:11 2011 (r13312) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Wed Jun 8 09:03:16 2011 (r13313) @@ -2,13 +2,64 @@ (defvar *jar-file-init* nil) +(defparameter *tmp-directory* + (make-pathname + :directory (append + (pathname-directory (pathname + (java:jcall "getAbsolutePath" + (java:jstatic "createTempFile" "java.io.File" + "jar" "tmp")))) + '("jar-pathname-tests")))) + + +(defvar *foo.lisp* + `((defun foo () + (labels ((output () + (format t "FOO here."))) + (output))))) + +(defvar *bar.lisp* + `((defvar *pathname* *load-pathname*) + (defvar *truename* *load-truename*) + + (defun bar () + (labels + ((output () + (format t "Some BAR~%*load-pathname* ~S~%*load-truename* ~S~%" + *pathname* *truename*))) + (output))) + (defvar *bar* t) + + (defun baz () + (format t "Some BAZ")))) + +(defvar *eek.lisp* + `((defun eek () + (format t "Another EEK.")) + (defun ook () + (let ((*load-verbose* t)) + (load (merge-pathnames #p"bar" *load-truename*)))) + (defun aak () + (format t "*LOAD-TRUENAME* is '~A'" *load-truename*)))) + +(defun write-forms (forms path) + (with-open-file (s path :direction :output :if-exists :supersede) + (with-standard-io-syntax + (dolist (form forms) + (print form s))))) + (defun jar-file-init () - (let* ((*default-pathname-defaults* *abcl-test-directory*) + (format t "~&Using ~A to create files for testing jar-pathnames.~%" *tmp-directory*) + (ensure-directories-exist *tmp-directory*) + (let* ((*default-pathname-defaults* *tmp-directory*) (asdf::*verbose-out* *standard-output*)) + (write-forms *foo.lisp* "foo.lisp") (compile-file "foo.lisp") + (write-forms *bar.lisp* "bar.lisp") (compile-file "bar.lisp") + (write-forms *eek.lisp* "eek.lisp") (compile-file "eek.lisp") - (let* ((tmpdir (merge-pathnames "tmp/" *abcl-test-directory*)) + (let* ((tmpdir (merge-pathnames "tmp/" *tmp-directory*)) (subdirs (mapcar (lambda (p) (merge-pathnames p tmpdir)) '("a/b/" "d/e+f/"))) @@ -37,7 +88,7 @@ (setf *jar-file-init* t)) (defmacro with-jar-file-init (&rest body) - `(let ((*default-pathname-defaults* *abcl-test-directory*)) + `(let ((*default-pathname-defaults* *tmp-directory*)) (progn (unless *jar-file-init* (jar-file-init)) @@ -158,33 +209,33 @@ (with-jar-file-init (probe-file "jar:file:baz.jar!/a/b/bar.abcl")) #p#.(format nil "jar:file:~A/baz.jar!/a/b/bar.abcl" - (namestring *abcl-test-directory*))) + (namestring *tmp-directory*))) (deftest jar-pathname.probe-file.3 (with-jar-file-init (probe-file "jar:jar:file:baz.jar!/a/b/bar.abcl!/bar._")) #p#.(format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._" - (namestring *abcl-test-directory*))) + (namestring *tmp-directory*))) (push 'jar-pathname.probe-file.4 *expected-failures*) (deftest jar-pathname.probe-file.4 (with-jar-file-init (probe-file "jar:file:baz.jar!/a/b")) #p#.(format nil "jar:file:~Abaz.jar!/a/b/" - (namestring *abcl-test-directory*))) + (namestring *tmp-directory*))) (push 'jar-pathname.probe-file.5 *expected-failures*) (deftest jar-pathname.probe-file.5 (with-jar-file-init (probe-file "jar:file:baz.jar!/a/b/")) #p#.(format nil "jar:file:~Abaz.jar!/a/b/" - (namestring *abcl-test-directory*))) + (namestring *tmp-directory*))) (deftest jar-pathname.probe-file.6 (with-jar-file-init (probe-file "jar:file:baz.jar!/d/e+f/bar.abcl")) #p#.(format nil "jar:file:~Abaz.jar!/d/e+f/bar.abcl" - (namestring *abcl-test-directory*))) + (namestring *tmp-directory*))) (deftest jar-pathname.merge-pathnames.1 (merge-pathnames From mevenson at common-lisp.net Thu Jun 9 06:03:21 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 08 Jun 2011 23:03:21 -0700 Subject: [armedbear-cvs] r13314 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Wed Jun 8 23:03:20 2011 New Revision: 13314 Log: Explicitly intialize *TMP-DIRECTORY* at compile and load time. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Wed Jun 8 09:03:16 2011 (r13313) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Wed Jun 8 23:03:20 2011 (r13314) @@ -2,15 +2,16 @@ (defvar *jar-file-init* nil) -(defparameter *tmp-directory* - (make-pathname - :directory (append - (pathname-directory (pathname - (java:jcall "getAbsolutePath" - (java:jstatic "createTempFile" "java.io.File" - "jar" "tmp")))) - '("jar-pathname-tests")))) +(defparameter *tmp-directory* nil) +(eval-when (:compile-toplevel :load-toplevel) + (let ((temp-file (java:jcall "getAbsolutePath" + (java:jstatic "createTempFile" "java.io.File" "jar" "tmp")))) + (setf *tmp-directory* + (make-pathname :directory + (append + (pathname-directory (pathname temp-file)) + '("jar-pathname-tests")))))) (defvar *foo.lisp* `((defun foo () From mevenson at common-lisp.net Thu Jun 9 13:01:19 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 09 Jun 2011 06:01:19 -0700 Subject: [armedbear-cvs] r13315 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Jun 9 06:01:16 2011 New Revision: 13315 Log: Fix ASDF working with jar archives. 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 Wed Jun 8 23:03:20 2011 (r13314) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Thu Jun 9 06:01:16 2011 (r13315) @@ -2135,7 +2135,9 @@ ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy +(defvar *debug-perform-compile-op* nil) (defmethod perform ((operation compile-op) (c cl-source-file)) + (push (list operation c) *debug-perform-compile-op*) #-:broken-fasl-loader (let ((source-file (component-pathname c)) ;; on some implementations, there are more than one output-file, @@ -3523,7 +3525,16 @@ (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) (if (absolute-pathname-p output-file) - (apply 'compile-file-pathname (lispize-pathname input-file) keys) + ;;; If the default ABCL rules for translating from a jar path to + ;;; a non-jar path have been affected, no further computation of + ;;; the output location is necessary. + (if (and (find :abcl *features*) + (pathname-device input-file) ; input-file is in a jar + (not (pathname-device output-file)) ; output-file is not in a jar + (equal (pathname-type input-file) "lisp") + (equal (pathname-type output-file) "abcl")) + output-file + (apply 'compile-file-pathname (lispize-pathname input-file) keys)) (apply-output-translations (apply 'compile-file-pathname (truenamize (lispize-pathname input-file)) From mevenson at common-lisp.net Thu Jun 9 13:03:05 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 09 Jun 2011 06:03:05 -0700 Subject: [armedbear-cvs] r13316 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Jun 9 06:03:05 2011 New Revision: 13316 Log: Remove inadvertent commit of debugging code. 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 Thu Jun 9 06:01:16 2011 (r13315) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Thu Jun 9 06:03:05 2011 (r13316) @@ -2135,9 +2135,7 @@ ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy -(defvar *debug-perform-compile-op* nil) (defmethod perform ((operation compile-op) (c cl-source-file)) - (push (list operation c) *debug-perform-compile-op*) #-:broken-fasl-loader (let ((source-file (component-pathname c)) ;; on some implementations, there are more than one output-file, From mevenson at common-lisp.net Thu Jun 9 15:24:32 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 09 Jun 2011 08:24:32 -0700 Subject: [armedbear-cvs] r13317 - trunk/abcl Message-ID: Author: mevenson Date: Thu Jun 9 08:24:31 2011 New Revision: 13317 Log: Make abcl-contrib.jar part of the default and release targets. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Thu Jun 9 06:03:05 2011 (r13316) +++ trunk/abcl/build.xml Thu Jun 9 08:24:31 2011 (r13317) @@ -430,7 +430,7 @@ + depends="abcl.jar,abcl.contrib,abcl.wrapper.unix,abcl.wrapper.windows"> Creates in-place exectuable shell wrapper in '${abcl.wrapper.file}' @@ -469,8 +469,19 @@ - - + + + + + + + + + + + @@ -479,14 +490,12 @@ -Packaged contribs in ${dist.dir}/abcl-contrib.jar. - -To use contribs, ensure that 'abcl-contrib.jar' is in the same -directory as 'abcl.jar', then +Packaged contribs in ${abcl-contrib.jar}. To use contribs, ensure that +this file is in the same directory as 'abcl.jar', and then CL-USER> (require 'abcl-contrib) -will place all the contribs in the ASDF registry path. +will place all the contribs in the ASDF registry. To load a contrib, something like @@ -711,7 +720,7 @@ - + @@ -720,6 +729,7 @@ + From mevenson at common-lisp.net Fri Jun 10 08:37:40 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 10 Jun 2011 01:37:40 -0700 Subject: [armedbear-cvs] r13318 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jun 10 01:37:39 2011 New Revision: 13318 Log: Update to asdf-2.016.1 to align with upstream ASDF. Fare patched the problems with compiling files with jars in a non-ABCL specific manner in COMPILE-FILE-PATHNAME*. 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 Thu Jun 9 08:24:31 2011 (r13317) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Fri Jun 10 01:37:39 2011 (r13318) @@ -3526,13 +3526,13 @@ ;;; If the default ABCL rules for translating from a jar path to ;;; a non-jar path have been affected, no further computation of ;;; the output location is necessary. - (if (and (find :abcl *features*) - (pathname-device input-file) ; input-file is in a jar - (not (pathname-device output-file)) ; output-file is not in a jar - (equal (pathname-type input-file) "lisp") - (equal (pathname-type output-file) "abcl")) - output-file - (apply 'compile-file-pathname (lispize-pathname input-file) keys)) + ;; (if (and (find :abcl *features*) + ;; (pathname-device input-file) ; input-file is in a jar + ;; (not (pathname-device output-file)) ; output-file is not in a jar + ;; (equal (pathname-type input-file) "lisp") + ;; (equal (pathname-type output-file) "abcl")) + ;; output-file + (apply 'compile-file-pathname (lispize-pathname input-file) keys);) (apply-output-translations (apply 'compile-file-pathname (truenamize (lispize-pathname input-file)) From mevenson at common-lisp.net Fri Jun 10 09:28:31 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 10 Jun 2011 02:28:31 -0700 Subject: [armedbear-cvs] r13319 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jun 10 02:28:30 2011 New Revision: 13319 Log: Actual commit of asdf-2.016.1. 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 Fri Jun 10 01:37:39 2011 (r13318) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Fri Jun 10 02:28:30 2011 (r13319) @@ -1,5 +1,5 @@ ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.016: Another System Definition Facility. +;;; This is ASDF 2.016.1: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -62,6 +62,11 @@ (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below #+(and ecl (not ecl-bytecmp)) (require :cmp) + #+gcl + (when (or (< system::*gcl-major-version* 2) + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 7))) + (pushnew :gcl-pre2.7 *features*)) #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*) #+(or unix cygwin) (pushnew :asdf-unix *features*) ;;; make package if it doesn't exist yet. @@ -84,14 +89,15 @@ ;; Strip out formatting that is not supported on Genera. ;; Has to be inside the eval-when to make Lispworks happy (!) (defmacro compatfmt (format) - #-genera format - #+genera + #-(or gcl genera) format + #+(or gcl genera) (loop :for (unsupported . replacement) :in - '(("~@<" . "") - ("; ~@;" . "; ") - ("~3i~_" . "") - ("~@:>" . "") - ("~:>" . "")) :do + `(("~3i~_" . "") + #+genera + ,@(("~@<" . "") + ("; ~@;" . "; ") + ("~@:>" . "") + ("~:>" . ""))) :do (loop :for found = (search unsupported format) :while found :do (setf format (concatenate 'simple-string @@ -106,7 +112,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.016") + (asdf-version "2.016.1") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -367,12 +373,6 @@ ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters ;;;; -(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) \"2.345.67\")." - *asdf-version*) - (defvar *resolve-symlinks* t "Determine whether or not ASDF resolves symlinks when defining systems. @@ -415,7 +415,7 @@ condition-arguments condition-form condition-format condition-location coerce-name) - #-cormanlisp + #-(or cormanlisp gcl-pre2.7) (ftype (function (t t) t) (setf module-components-by-name))) ;;;; ------------------------------------------------------------------------- @@ -423,19 +423,10 @@ #+cormanlisp (progn (deftype logical-pathname () nil) - (defun make-broadcast-stream () *error-output*) - (defun file-namestring (p) + (defun* make-broadcast-stream () *error-output*) + (defun* file-namestring (p) (setf p (pathname p)) - (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))) - (defparameter *count* 3) - (defun dbg (&rest x) - (format *error-output* "~S~%" x))) -#+cormanlisp -(defun maybe-break () - (decf *count*) - (unless (plusp *count*) - (setf *count* 3) - (break))) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities @@ -444,7 +435,7 @@ ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) `(progn - #+(or ecl gcl) (fmakunbound ',name) + #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name) #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl `(declaim (notinline ,name))) @@ -515,8 +506,11 @@ :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) - "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname -does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS. + "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that +if the SPECIFIED pathname does not have an absolute directory, +then the HOST and DEVICE both come from the DEFAULTS, whereas +if the SPECIFIED pathname does have an absolute directory, +then the HOST and DEVICE both come from the SPECIFIED. Also, if either argument is NIL, then the other argument is returned unmodified." (when (null specified) (return-from merge-pathnames* defaults)) (when (null defaults) (return-from merge-pathnames* specified)) @@ -730,7 +724,7 @@ #+genera (unless (fboundp 'ensure-directories-exist) - (defun ensure-directories-exist (path) + (defun* ensure-directories-exist (path) (fs:create-directories-recursively (pathname path)))) (defun* absolute-pathname-p (pathspec) @@ -798,22 +792,25 @@ (null nil) (string (probe-file* (parse-namestring p))) (pathname (unless (wild-pathname-p p) - #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p) + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl) + '(probe-file p) #+clisp (aif (find-symbol* '#:probe-pathname :ext) `(ignore-errors (,it p))) '(ignore-errors (truename p))))))) -(defun* truenamize (p) +(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) "Resolve as much of a pathname as possible" (block nil - (when (typep p '(or null logical-pathname)) (return p)) - (let* ((p (merge-pathnames* p)) - (directory (pathname-directory p))) + (when (typep pathname '(or null logical-pathname)) (return pathname)) + (let ((p (merge-pathnames* pathname defaults))) (when (typep p 'logical-pathname) (return p)) (let ((found (probe-file* p))) (when found (return found))) - #-(or cmu sbcl scl) (when (stringp directory) (return p)) - (when (not (eq :absolute (car directory))) (return p)) + (unless (absolute-pathname-p p) + (let ((true-defaults (ignore-errors (truename defaults)))) + (when true-defaults + (setf p (merge-pathnames pathname true-defaults))))) + (unless (absolute-pathname-p p) (return p)) (let ((sofar (probe-file* (pathname-root p)))) (unless sofar (return p)) (flet ((solution (directories) @@ -824,7 +821,9 @@ :type (pathname-type p) :version (pathname-version p)) sofar))) - (loop :for component :in (cdr directory) + (loop :with directory = (normalize-pathname-directory-component + (pathname-directory p)) + :for component :in (cdr directory) :for rest :on (cdr directory) :for more = (probe-file* (merge-pathnames* @@ -847,7 +846,7 @@ (and path (resolve-symlinks path)) path)) -(defun ensure-pathname-absolute (path) +(defun* ensure-pathname-absolute (path) (cond ((absolute-pathname-p path) path) ((stringp path) (ensure-pathname-absolute (pathname path))) @@ -877,7 +876,7 @@ (merge-pathnames* *wild-path* path)) #-scl -(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) +(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) @@ -961,7 +960,7 @@ (defgeneric* (setf component-property) (new-value component property)) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-gcl :compile-toplevel :load-toplevel :execute) (defgeneric* (setf module-components-by-name) (new-value module))) (defgeneric* version-satisfies (component version)) @@ -1270,8 +1269,8 @@ (slot-value component 'absolute-pathname) (let ((pathname (merge-pathnames* - (component-relative-pathname component) - (pathname-directory-pathname (component-parent-pathname component))))) + (component-relative-pathname component) + (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) (error (compatfmt "~@") pathname (component-find-path component))) @@ -1312,7 +1311,13 @@ (return-from version-satisfies t)) (version-satisfies (component-version c) version)) -(defun parse-version (string &optional on-error) +(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) \"2.345.67\")." + *asdf-version*) + +(defun* parse-version (string &optional on-error) "Parse a version string as a series of natural integers separated by dots. Return a (non-null) list of integers if the string is valid, NIL otherwise. If on-error is error, warn, or designates a function of compatible signature, @@ -1531,7 +1536,7 @@ (let ((*systems-being-defined* (make-hash-table :test 'equal))) (funcall thunk)))) -(defmacro with-system-definitions (() &body body) +(defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () , at body))) (defun* load-sysdef (name pathname) @@ -2113,7 +2118,7 @@ (flags :initarg :flags :accessor compile-op-flags :initform nil))) -(defun output-file (operation component) +(defun* output-file (operation component) "The unique output file of performing OPERATION on COMPONENT" (let ((files (output-files operation component))) (assert (length=n-p files 1)) @@ -2144,8 +2149,8 @@ (*compile-file-warnings-behaviour* (operation-on-warnings operation)) (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) - (apply *compile-op-compile-file-function* source-file :output-file output-file - (compile-op-flags operation)) + (apply *compile-op-compile-file-function* source-file + :output-file output-file (compile-op-flags operation)) (unless output (error 'compile-error :component c :operation operation)) (when failure-p @@ -3523,20 +3528,13 @@ (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) (if (absolute-pathname-p output-file) - ;;; If the default ABCL rules for translating from a jar path to - ;;; a non-jar path have been affected, no further computation of - ;;; the output location is necessary. - ;; (if (and (find :abcl *features*) - ;; (pathname-device input-file) ; input-file is in a jar - ;; (not (pathname-device output-file)) ; output-file is not in a jar - ;; (equal (pathname-type input-file) "lisp") - ;; (equal (pathname-type output-file) "abcl")) - ;; output-file - (apply 'compile-file-pathname (lispize-pathname input-file) keys);) + ;; what cfp should be doing, w/ mp* instead of mp + (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys))) + (defaults (make-pathname + :type type :defaults (merge-pathnames* input-file)))) + (merge-pathnames* output-file defaults)) (apply-output-translations - (apply 'compile-file-pathname - (truenamize (lispize-pathname input-file)) - keys)))) + (apply 'compile-file-pathname input-file keys)))) (defun* tmpize-pathname (x) (make-pathname @@ -3737,11 +3735,11 @@ (defparameter *wild-asd* (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) -(defun directory-asd-files (directory) +(defun* directory-asd-files (directory) (ignore-errors (directory* (merge-pathnames* *wild-asd* directory)))) -(defun subdirectories (directory) +(defun* subdirectories (directory) (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* @@ -3769,17 +3767,17 @@ #+(or cmu lispworks scl) x))) dirs)) -(defun collect-asds-in-directory (directory collect) +(defun* collect-asds-in-directory (directory collect) (map () collect (directory-asd-files directory))) -(defun collect-sub*directories (directory collectp recursep collector) +(defun* collect-sub*directories (directory collectp recursep collector) (when (funcall collectp directory) (funcall collector directory)) (dolist (subdir (subdirectories directory)) (when (funcall recursep subdir) (collect-sub*directories subdir collectp recursep collector)))) -(defun collect-sub*directories-asd-files +(defun* collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect) From mevenson at common-lisp.net Fri Jun 10 10:12:03 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 10 Jun 2011 03:12:03 -0700 Subject: [armedbear-cvs] r13320 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jun 10 03:12:02 2011 New Revision: 13320 Log: Untabify. Modified: trunk/abcl/src/org/armedbear/lisp/zip.java Modified: trunk/abcl/src/org/armedbear/lisp/zip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/zip.java Fri Jun 10 02:28:30 2011 (r13319) +++ trunk/abcl/src/org/armedbear/lisp/zip.java Fri Jun 10 03:12:02 2011 (r13320) @@ -84,7 +84,7 @@ pathname.writeToString())); } File file = new File(namestring); - makeEntry(out, file); + makeEntry(out, file); list = list.cdr(); } out.close(); @@ -144,7 +144,7 @@ list = list.cdr(); continue; } - makeEntry(out, file, directory + file.getName()); + makeEntry(out, file, directory + file.getName()); list = list.cdr(); } out.close(); @@ -158,27 +158,27 @@ private static final Primitive zip = new zip(); private void makeEntry(ZipOutputStream zip, File file) - throws FileNotFoundException, IOException + throws FileNotFoundException, IOException { - makeEntry(zip, file, file.getName()); + makeEntry(zip, file, file.getName()); } private void makeEntry(ZipOutputStream zip, File file, String name) - throws FileNotFoundException, IOException + throws FileNotFoundException, IOException { byte[] buffer = new byte[4096]; - long lastModified = file.lastModified(); - FileInputStream in = new FileInputStream(file); - ZipEntry entry = new ZipEntry(name); - if (lastModified > 0) { - entry.setTime(lastModified); - } - zip.putNextEntry(entry); - int n; - while ((n = in.read(buffer)) > 0) - zip.write(buffer, 0, n); - zip.closeEntry(); - in.close(); + long lastModified = file.lastModified(); + FileInputStream in = new FileInputStream(file); + ZipEntry entry = new ZipEntry(name); + if (lastModified > 0) { + entry.setTime(lastModified); + } + zip.putNextEntry(entry); + int n; + while ((n = in.read(buffer)) > 0) + zip.write(buffer, 0, n); + zip.closeEntry(); + in.close(); } - + } From mevenson at common-lisp.net Fri Jun 10 10:12:24 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 10 Jun 2011 03:12:24 -0700 Subject: [armedbear-cvs] r13321 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jun 10 03:12:24 2011 New Revision: 13321 Log: Use TRUENAME when determining name for hierarchial zip archives. Fixes the three arg SYSTEM:ZIP under OSX. Modified: trunk/abcl/src/org/armedbear/lisp/zip.java Modified: trunk/abcl/src/org/armedbear/lisp/zip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/zip.java Fri Jun 10 03:12:02 2011 (r13320) +++ trunk/abcl/src/org/armedbear/lisp/zip.java Fri Jun 10 03:12:24 2011 (r13321) @@ -106,13 +106,13 @@ zipfilePathname.writeToString())); ZipOutputStream out = new ZipOutputStream(new FileOutputStream(zipfileNamestring)); - Pathname root = (Pathname)coerceToPathname(third); + Pathname root = (Pathname) Pathname.truename(coerceToPathname(third)); String rootPath = root.getDirectoryNamestring(); int rootPathLength = rootPath.length(); Set directories = new HashSet(); LispObject list = second; while (list != NIL) { - Pathname pathname = coerceToPathname(list.car()); + Pathname pathname = (Pathname) Pathname.truename(coerceToPathname(list.car())); String namestring = pathname.getNamestring(); if (namestring == null) { // Clean up before signalling error. From mevenson at common-lisp.net Fri Jun 10 10:15:51 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 10 Jun 2011 03:15:51 -0700 Subject: [armedbear-cvs] r13322 - trunk/abcl/contrib/asdf-install Message-ID: Author: mevenson Date: Fri Jun 10 03:15:51 2011 New Revision: 13322 Log: Make asdf-install version compatible with ASDF2 requirements. Muffles the warning when loading ASDF-INSTALL. Modified: trunk/abcl/contrib/asdf-install/asdf-install.asd Modified: trunk/abcl/contrib/asdf-install/asdf-install.asd ============================================================================== --- trunk/abcl/contrib/asdf-install/asdf-install.asd Fri Jun 10 03:12:24 2011 (r13321) +++ trunk/abcl/contrib/asdf-install/asdf-install.asd Fri Jun 10 03:15:51 2011 (r13322) @@ -12,7 +12,7 @@ (defsystem asdf-install #+:sbcl :depends-on #+:sbcl (sb-bsd-sockets) - :version "0.6.10-ABCL.1" + :version "0.6.10.2" :author "Dan Barlow , Edi Weitz and many others. See the file COPYRIGHT for more details." :maintainer "Gary Warren King " :components ((:file "defpackage") From mevenson at common-lisp.net Fri Jun 10 15:52:19 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 10 Jun 2011 08:52:19 -0700 Subject: [armedbear-cvs] r13323 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Fri Jun 10 08:52:17 2011 New Revision: 13323 Log: Update remote jar for pathname tests. An incompatible FASL format prevented the tests from working. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Fri Jun 10 03:15:51 2011 (r13322) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Fri Jun 10 08:52:17 2011 (r13323) @@ -154,7 +154,7 @@ ;;; XXX come up with a better abstraction (defvar *url-jar-pathname-base* - "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20101103a.jar!/") + "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20110610a.jar!/") (defmacro load-url-relative (path) `(load (format nil "~A~A" *url-jar-pathname-base* ,path))) From mevenson at common-lisp.net Fri Jun 10 15:52:34 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 10 Jun 2011 08:52:34 -0700 Subject: [armedbear-cvs] r13324 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Fri Jun 10 08:52:34 2011 New Revision: 13324 Log: Fix problems with remaining jar-pathname tests. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Fri Jun 10 08:52:17 2011 (r13323) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Fri Jun 10 08:52:34 2011 (r13324) @@ -8,10 +8,10 @@ (let ((temp-file (java:jcall "getAbsolutePath" (java:jstatic "createTempFile" "java.io.File" "jar" "tmp")))) (setf *tmp-directory* - (make-pathname :directory - (append - (pathname-directory (pathname temp-file)) - '("jar-pathname-tests")))))) + (truename (make-pathname :directory + (append + (pathname-directory (pathname temp-file)) + '("jar-pathname-tests"))))))) (defvar *foo.lisp* `((defun foo () @@ -204,7 +204,7 @@ (with-jar-file-init (probe-file "jar:file:baz.jar!/eek.lisp")) #p#.(format nil "jar:file:~A/baz.jar!/eek.lisp" - (namestring *abcl-test-directory*))) + (namestring *tmp-directory*))) (deftest jar-pathname.probe-file.2 (with-jar-file-init @@ -374,9 +374,9 @@ t) (deftest jar-pathname.11 - (let ((s "jar:file:/foo/bar/a%20space%3f/that!/this")) + (let ((s (string-downcase "jar:file:/foo/bar/a%20space%3f/that!/this"))) (string= s - (namestring (pathname s)))) + (string-downcase (namestring (pathname s))))) t) ;;; We allow jar-pathname to be contructed without a device to allow From mevenson at common-lisp.net Fri Jun 10 15:52:50 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 10 Jun 2011 08:52:50 -0700 Subject: [armedbear-cvs] r13325 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jun 10 08:52:50 2011 New Revision: 13325 Log: Fix the URI decoding algorithim in Pathname. Provide EXT:URI-DECODE and EXT:URI-ENCODE for access to the routines used by Pathname. 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 Fri Jun 10 08:52:34 2011 (r13324) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Fri Jun 10 08:52:50 2011 (r13325) @@ -2429,14 +2429,52 @@ Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(coerceToPathname(obj)); } + + @DocString(name="uri-decode", + args="string => string", + doc="Decode percent escape sequences in the manner of URI encodings.") + private static final Primitive URI_DECODE = new pf_uri_decode(); + private static final class pf_uri_decode extends Primitive { + pf_uri_decode() { + super("uri-decode", PACKAGE_EXT, true); + } + @Override + public LispObject execute(LispObject arg) { + if (!(arg instanceof AbstractString)) { + return error(new TypeError(arg, Symbol.STRING)); + } + String result = uriDecode(((AbstractString)arg).toString()); + return new SimpleString(result); + } + }; + static String uriDecode(String s) { try { - URI uri = new URI(null, null, null, s, null); - return uri.toASCIIString().substring(1); + URI uri = new URI("file://foo?" + s); + return uri.getQuery(); } catch (URISyntaxException e) {} return null; // Error } + + @DocString(name="uri-encode", + args="string => string", + doc="Encode percent escape sequences in the manner of URI encodings.") + private static final Primitive URI_ENCODE = new pf_uri_encode(); + private static final class pf_uri_encode extends Primitive { + pf_uri_encode() { + super("uri-encode", PACKAGE_EXT, true); + } + @Override + public LispObject execute(LispObject arg) { + if (!(arg instanceof AbstractString)) { + return error(new TypeError(arg, Symbol.STRING)); + } + String result = uriEncode(((AbstractString)arg).toString()); + return new SimpleString(result); + } + }; + static String uriEncode(String s) { // The constructor we use here only allows absolute paths, so // we manipulate the input and output correspondingly. From mevenson at common-lisp.net Fri Jun 10 15:53:12 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 10 Jun 2011 08:53:12 -0700 Subject: [armedbear-cvs] r13326 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Fri Jun 10 08:53:12 2011 New Revision: 13326 Log: Add tests for whitespace in pathname. Refactor jar-pathname tests via LOAD-JAR-RELATIVE macro. Use DEFPARAMETER rather than DEFVAR. Add paths containing whitespace to local jar in preparation for expanding the test suite to more failing cases. *TMP-JAR_PATH* now contains the path to jar used for testing. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Fri Jun 10 08:52:50 2011 (r13325) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Fri Jun 10 08:53:12 2011 (r13326) @@ -1,8 +1,9 @@ (in-package #:abcl.test.lisp) -(defvar *jar-file-init* nil) - (defparameter *tmp-directory* nil) +(defparameter *tmp-directory-whitespace* nil) +(defparameter *tmp-jar-path* nil) +(defparameter *tmp-jar-path-whitespace* nil) (eval-when (:compile-toplevel :load-toplevel) (let ((temp-file (java:jcall "getAbsolutePath" @@ -11,7 +12,9 @@ (truename (make-pathname :directory (append (pathname-directory (pathname temp-file)) - '("jar-pathname-tests"))))))) + '("jar-pathname-tests")))) + *tmp-directory-whitespace* + (merge-pathnames "a/directory with/s p a/" *tmp-directory*)))) (defvar *foo.lisp* `((defun foo () @@ -56,6 +59,8 @@ (asdf::*verbose-out* *standard-output*)) (write-forms *foo.lisp* "foo.lisp") (compile-file "foo.lisp") + (write-forms *foo.lisp* "foo bar.lisp") + (compile-file "foo bar.lisp") (write-forms *bar.lisp* "bar.lisp") (compile-file "bar.lisp") (write-forms *eek.lisp* "eek.lisp") @@ -63,102 +68,131 @@ (let* ((tmpdir (merge-pathnames "tmp/" *tmp-directory*)) (subdirs (mapcar (lambda (p) (merge-pathnames p tmpdir)) - '("a/b/" "d/e+f/"))) + '("a/b/" "d/e+f/" "path/with a couple/spaces/in it/"))) (sub1 (first subdirs)) - (sub2 (second subdirs))) + (sub2 (second subdirs)) + (sub3 (third subdirs))) (when (probe-directory tmpdir) (delete-directory-and-files tmpdir)) (mapcar (lambda (p) (ensure-directories-exist p)) subdirs) (sys:unzip (merge-pathnames "foo.abcl") tmpdir) (sys:unzip (merge-pathnames "foo.abcl") sub1) + (sys:unzip (merge-pathnames "foo.abcl") sub3) + (sys:unzip (merge-pathnames "foo bar.abcl") sub3) (cl-fad-copy-file (merge-pathnames "bar.abcl") (merge-pathnames "bar.abcl" tmpdir)) (cl-fad-copy-file (merge-pathnames "bar.abcl") (merge-pathnames "bar.abcl" sub1)) + (cl-fad-copy-file (merge-pathnames "foo bar.abcl") + (merge-pathnames "foo bar.abcl" sub1)) (cl-fad-copy-file (merge-pathnames "bar.abcl") (merge-pathnames "bar.abcl" sub2)) + (cl-fad-copy-file (merge-pathnames "bar.abcl") + (merge-pathnames "bar.abcl" sub3)) + (cl-fad-copy-file (merge-pathnames "foo bar.abcl") + (merge-pathnames "foo bar.abcl" sub3)) (cl-fad-copy-file (merge-pathnames "eek.lisp") (merge-pathnames "eek.lisp" tmpdir)) (cl-fad-copy-file (merge-pathnames "eek.lisp") (merge-pathnames "eek.lisp" sub1)) - (sys:zip (merge-pathnames "baz.jar") - (loop :for p :in (list tmpdir sub1 sub2) - :appending (directory (merge-pathnames "*" p))) - tmpdir) - #+nil (delete-directory-and-files dir))) - (setf *jar-file-init* t)) + (setf *tmp-jar-path* + (sys:zip (merge-pathnames "baz.jar") + (loop :for p :in (list tmpdir sub1 sub2 sub3) + :appending (directory (merge-pathnames "*" p))) + tmpdir)) + (ensure-directories-exist *tmp-directory-whitespace*) + (setf *tmp-jar-path-whitespace* + (merge-pathnames "baz.jar" *tmp-directory-whitespace*)) + (cl-fad-copy-file *tmp-jar-path* *tmp-jar-path-whitespace*)))) + +(defun clean-jar-tests () + (when (probe-file *tmp-directory*) + (delete-directory-and-files *tmp-directory*))) (defmacro with-jar-file-init (&rest body) `(let ((*default-pathname-defaults* *tmp-directory*)) (progn - (unless *jar-file-init* + (unless (and *tmp-jar-path* (probe-file *tmp-jar-path*)) (jar-file-init)) , at body))) +(defmacro load-from-jar (jar path) + `(with-jar-file-init + (load (format nil "jar:file:~A!/~A" ,jar ,path)))) + (deftest jar-pathname.load.1 - (with-jar-file-init - (load "jar:file:baz.jar!/foo")) + (load-from-jar *tmp-jar-path* "foo") t) (deftest jar-pathname.load.2 - (with-jar-file-init - (load "jar:file:baz.jar!/bar")) + (load-from-jar *tmp-jar-path* "bar") t) (deftest jar-pathname.load.3 - (with-jar-file-init - (load "jar:file:baz.jar!/bar.abcl")) + (load-from-jar *tmp-jar-path* "bar.abcl") t) (deftest jar-pathname.load.4 - (with-jar-file-init - (load "jar:file:baz.jar!/eek")) + (load-from-jar *tmp-jar-path* "eek") t) (deftest jar-pathname.load.5 - (with-jar-file-init - (load "jar:file:baz.jar!/eek.lisp")) + (load-from-jar *tmp-jar-path* "eek.lisp") t) (deftest jar-pathname.load.6 - (with-jar-file-init - (load "jar:file:baz.jar!/a/b/foo")) + (load-from-jar *tmp-jar-path* "foo") t) (deftest jar-pathname.load.7 - (with-jar-file-init - (load "jar:file:baz.jar!/a/b/bar")) + (load-from-jar *tmp-jar-path* "a/b/bar") t) (deftest jar-pathname.load.8 - (with-jar-file-init - (load "jar:file:baz.jar!/a/b/bar.abcl")) + (load-from-jar *tmp-jar-path* "a/b/bar.abcl") t) (deftest jar-pathname.load.9 - (with-jar-file-init - (load "jar:file:baz.jar!/a/b/eek")) + (load-from-jar *tmp-jar-path* "a/b/eek") t) (deftest jar-pathname.load.10 - (with-jar-file-init - (load "jar:file:baz.jar!/a/b/eek.lisp")) + (load-from-jar *tmp-jar-path* "a/b/eek.lisp") t) (deftest jar-pathname.load.11 - (with-jar-file-init - (load "jar:file:baz.jar!/d/e+f/bar.abcl")) + (load-from-jar *tmp-jar-path* "d/e+f/bar.abcl") t) -;;; wrapped in PROGN for easy disabling without a network connection -;;; XXX come up with a better abstraction +(deftest jar-pathname.load.12 + (load-from-jar *tmp-jar-path* "a/b/foo%20bar.abcl") + t) + +(deftest jar-pathname.load.13 + (load-from-jar *tmp-jar-path* "a/b/foo bar.abcl") + t) -(defvar *url-jar-pathname-base* +(deftest jar-pathname.load.14 + (load-from-jar *tmp-jar-path-whitespace* "a/b/foo.abcl") + t) + +(deftest jar-pathname.load.15 + (load-from-jar *tmp-jar-path-whitespace* "a/b/foo bar.abcl") + t) + +(deftest jar-pathname.load.16 + (load-from-jar *tmp-jar-path-whitespace* "a/b/foo%20bar.abcl") + t) + +(defparameter *url-jar-pathname-base* "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20110610a.jar!/") (defmacro load-url-relative (path) `(load (format nil "~A~A" *url-jar-pathname-base* ,path))) +;;; wrapped in PROGN for easy disabling without a network connection +;;; XXX come up with a better abstraction + (progn (deftest jar-pathname.load.http.1 (load-url-relative "foo") From mevenson at common-lisp.net Tue Jun 14 09:20:58 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 14 Jun 2011 02:20:58 -0700 Subject: [armedbear-cvs] r13327 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jun 14 02:20:56 2011 New Revision: 13327 Log: Allow JCOERCE to convert any number to java.lang.Byte. Maps any number passed to to its two's complement 8bit byte representation, meaning that it will which may not be what one would wish. Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java Fri Jun 10 08:53:12 2011 (r13326) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Tue Jun 14 02:20:56 2011 (r13327) @@ -68,6 +68,14 @@ if(intendedClass != null) { intendedClass = Java.maybeBoxClass(intendedClass); if(!intendedClass.isInstance(obj)) { + if (intendedClass.equals(java.lang.Byte.class) + && obj instanceof java.lang.Number) { + // Maps any number to two's complement 8bit byte representation + // ??? Is this a reasonable thing? + this.obj = ((java.lang.Number)obj).byteValue(); + this.intendedClass = intendedClass; + return; + } throw new ClassCastException(obj + " can not be cast to " + intendedClass); } } From mevenson at common-lisp.net Tue Jun 14 10:05:04 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 14 Jun 2011 03:05:04 -0700 Subject: [armedbear-cvs] r13328 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jun 14 03:05:04 2011 New Revision: 13328 Log: Fix JNEW-ARRAY-FROM-ARRAY to create byte[] arrays. 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 Tue Jun 14 02:20:56 2011 (r13327) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Tue Jun 14 03:05:04 2011 (r13328) @@ -709,7 +709,14 @@ LispObject v = args[1]; for (int i = 2; i no ControlTransfer From mevenson at common-lisp.net Wed Jun 15 06:26:33 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 14 Jun 2011 23:26:33 -0700 Subject: [armedbear-cvs] r13329 - trunk/abcl/tools Message-ID: Author: mevenson Date: Tue Jun 14 23:26:32 2011 New Revision: 13329 Log: Fast SHA-{1,256,512} cryptographic hashes for files. Includes the start of a benchmark that seems to show that using NIO direcly without involving Lisp streams works a couple orders of magnitude faster. A definite point of optimization would be to have a java.nio.ByteBuffer backed Stream that could be used as source and/or a sync for fast io via FileChannel. Added: trunk/abcl/tools/digest.lisp Added: trunk/abcl/tools/digest.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/digest.lisp Tue Jun 14 23:26:32 2011 (r13329) @@ -0,0 +1,68 @@ +(defvar *digest-types* + '((:sha-1 . "SHA-1") + (:sha-256 . "SHA-256") + (:sha-512 . "SHA-512"))) + +(defconstant +byte-buffer-rewind+ + (jmethod "java.nio.ByteBuffer" "rewind")) +(defconstant +byte-buffer-get+ + (jmethod "java.nio.ByteBuffer" "get" "[B" "int" "int")) +(defconstant +digest-update+ + (jmethod "java.security.MessageDigest" "update" "[B" "int" "int")) + +;;; needs ABCL svn > r13328 and is probably not faster than the NIO version + +(defun digest-file-1 (path &key (digest :sha-256)) + (let* ((digest-type (cdr (assoc digest *digest-types*))) + (digest (jstatic "getInstance" "java.security.MessageDigest" digest-type)) + (buffer (make-array 8192 :element-type '(unsigned-byte 8)))) + (with-open-file (input path :element-type '(unsigned-byte 8)) + (loop :for bytes = (read-sequence buffer input) + :while (plusp bytes) + :do + (jcall-raw "update" digest + (jnew-array-from-array "byte" buffer) 0 bytes)) + (jcall "digest" digest)))) + +(defun digest-file (path &key (digest :sha-256)) + (let* ((digest-type (cdr (assoc digest *digest-types*))) + (digest (jstatic "getInstance" "java.security.MessageDigest" digest-type)) + (namestring (if (pathnamep path) (namestring path) path)) + (file-input-stream (jnew "java.io.FileInputStream" namestring)) + (channel (jcall "getChannel" file-input-stream)) + (length 8192) + (buffer (jstatic "allocateDirect" "java.nio.ByteBuffer" length)) + (array (jnew-array "byte" length))) + (do ((read (jcall "read" channel buffer) + (jcall "read" channel buffer))) + ((not (> read 0))) + (jcall +byte-buffer-rewind+ buffer) + (jcall +byte-buffer-get+ buffer array 0 read) + (jcall +byte-buffer-rewind+ buffer) + (jcall +digest-update+ digest array 0 read)) + (jcall "digest" digest))) + +(defun ascii-digest (digest) + (format nil "~{~X~}" + (mapcar (lambda (b) (if (< b 0) (+ 256 b) b)) + (java::list-from-jarray digest)))) + +(defun benchmark (directory) + (let (results start-1 end-1 start-2 end-2) + (dolist (entry (directory directory)) + (setf start-1 (get-internal-run-time)) + (digest-file-1 entry) + (setf end-1 (get-internal-run-time)) + (setf start-2 (get-internal-run-time)) + (digest-file entry) + (setf end-2 (get-internal-run-time)) + (let ((result (list entry (- end-1 start-1) (- end-2 start-2)))) + (format t "~&~A" result) + (push result results))) + results)) + + + + + + From mevenson at common-lisp.net Wed Jun 15 09:26:03 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 15 Jun 2011 02:26:03 -0700 Subject: [armedbear-cvs] r13330 - trunk/abcl/tools Message-ID: Author: mevenson Date: Wed Jun 15 02:26:03 2011 New Revision: 13330 Log: Create API for message digests via generic function DIGEST. DIGEST-PATH will return the ascii encoding of the SHA-256 cryptographic hash of the resource at PATH as fast as possible. Added: trunk/abcl/tools/abcl-tools.asd Modified: trunk/abcl/tools/digest.lisp Added: trunk/abcl/tools/abcl-tools.asd ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/abcl-tools.asd Wed Jun 15 02:26:03 2011 (r13330) @@ -0,0 +1,9 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP -*- +(require 'asdf) +(in-package :asdf) + +(defsystem :abcl-tools :version "0.1.0" :components + ((:module src :pathname "" :components + ((:file "digest") + (:file "code-grapher"))))) + \ No newline at end of file Modified: trunk/abcl/tools/digest.lisp ============================================================================== --- trunk/abcl/tools/digest.lisp Tue Jun 14 23:26:32 2011 (r13329) +++ trunk/abcl/tools/digest.lisp Wed Jun 15 02:26:03 2011 (r13330) @@ -1,8 +1,22 @@ +;;;; Cryptographic message digest calculation with ABCL with different implementations. +;;;; +;;;; Mark +;;;; + +(in-package :cl-user) + +;;; API +(defgeneric digest (url algorithim &optional (digest 'sha-256)) + (:documentation "Digest byte based resource at URL with ALGORITHIM.")) +(defun digest-path (path) (ascii-digest (digest path 'nio 'sha-256))) + (defvar *digest-types* - '((:sha-1 . "SHA-1") - (:sha-256 . "SHA-256") - (:sha-512 . "SHA-512"))) + '((sha-1 . "SHA-1") + (sha-256 . "SHA-256") + (sha-512 . "SHA-512")) + "Normalization of cryptographic digest naming.") +;;; Implementation (defconstant +byte-buffer-rewind+ (jmethod "java.nio.ByteBuffer" "rewind")) (defconstant +byte-buffer-get+ @@ -10,24 +24,15 @@ (defconstant +digest-update+ (jmethod "java.security.MessageDigest" "update" "[B" "int" "int")) -;;; needs ABCL svn > r13328 and is probably not faster than the NIO version +(defmethod digest ((url t) (algorithim (eql 'nio)) &optional (digest 'sha-256)) + "Calculate digest with default of :SHA-256 pathname specified by URL. +Returns an array of JVM primitive signed 8-bit bytes. -(defun digest-file-1 (path &key (digest :sha-256)) - (let* ((digest-type (cdr (assoc digest *digest-types*))) - (digest (jstatic "getInstance" "java.security.MessageDigest" digest-type)) - (buffer (make-array 8192 :element-type '(unsigned-byte 8)))) - (with-open-file (input path :element-type '(unsigned-byte 8)) - (loop :for bytes = (read-sequence buffer input) - :while (plusp bytes) - :do - (jcall-raw "update" digest - (jnew-array-from-array "byte" buffer) 0 bytes)) - (jcall "digest" digest)))) +*DIGEST-TYPES* controls the allowable digest types." -(defun digest-file (path &key (digest :sha-256)) (let* ((digest-type (cdr (assoc digest *digest-types*))) (digest (jstatic "getInstance" "java.security.MessageDigest" digest-type)) - (namestring (if (pathnamep path) (namestring path) path)) + (namestring (if (pathnamep url) (namestring url) url)) (file-input-stream (jnew "java.io.FileInputStream" namestring)) (channel (jcall "getChannel" file-input-stream)) (length 8192) @@ -42,27 +47,55 @@ (jcall +digest-update+ digest array 0 read)) (jcall "digest" digest))) +(defmethod digest ((url pathname) (algorithim (eql 'lisp)) &optional (digest 'sha-256)) + "Compute digest of URL in Lisp where possible. + +Currently much slower that using 'nio. + +Needs ABCL svn > r13328." + + (let* ((digest-type (cdr (assoc digest *digest-types*))) + (digest (jstatic "getInstance" "java.security.MessageDigest" digest-type)) + (buffer (make-array 8192 :element-type '(unsigned-byte 8)))) + (with-open-file (input url :element-type '(unsigned-byte 8)) + (loop + :for + bytes = (read-sequence buffer input) + :while + (plusp bytes) + :do + (jcall-raw "update" digest + (jnew-array-from-array "byte" buffer) 0 bytes)) + (jcall "digest" digest)))) + (defun ascii-digest (digest) (format nil "~{~X~}" (mapcar (lambda (b) (if (< b 0) (+ 256 b) b)) (java::list-from-jarray digest)))) (defun benchmark (directory) - (let (results start-1 end-1 start-2 end-2) + "For a given DIRECTORY containing a wildcard of files, run the benchmark tests." + (let (results) + (flet ((benchmark (task) + (let (start end result) + (psetf start (get-internal-run-time) + result (push (funcall task) result) + end (get-internal-run-time)) + (nconc result (list start (- end start)))))) (dolist (entry (directory directory)) - (setf start-1 (get-internal-run-time)) - (digest-file-1 entry) - (setf end-1 (get-internal-run-time)) - (setf start-2 (get-internal-run-time)) - (digest-file entry) - (setf end-2 (get-internal-run-time)) - (let ((result (list entry (- end-1 start-1) (- end-2 start-2)))) - (format t "~&~A" result) - (push result results))) - results)) - - - - - - + (let ((result + (list + (list 'nio (benchmark (lambda () (digest entry 'nio)))) + (list 'lisp (benchmark (lambda () (digest entry 'lisp))))))) + (format t "~&~{~A~&~A~}" result) + (push result results)))))) + +;;; Deprecated +(setf (symbol-function 'digest-file-1) #'digest) + +;;; Test + +#| +(benchmark "/usr/local/bin/*") ;; unix +(benchmark "c:/*") ;; win32 +|# From mevenson at common-lisp.net Wed Jun 15 18:17:13 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 15 Jun 2011 11:17:13 -0700 Subject: [armedbear-cvs] r13331 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Wed Jun 15 11:17:12 2011 New Revision: 13331 Log: Start outlining a manual. We go with LaTex for source. I want: a) a diff-able documentaion source format b) reasonable control over both print and online typography c) free (libre) toolchain d) the ability to include diagrams e) extensible reference (and cross reference) processing Honestly, I am not very satisfied with current mechanisms to go from LaTeX source to online content, so I hope to improve the transformation. Added: trunk/abcl/doc/manual/ trunk/abcl/doc/manual/abcl.tex Added: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/doc/manual/abcl.tex Wed Jun 15 11:17:12 2011 (r13331) @@ -0,0 +1,73 @@ +\documentclass[10pt]{article} + +\usepackage{color,hyperref} +\definecolor{darkblue}{rgb}{0.0,0.0,0.3} +\hypersetup{colorlinks,breaklinks, + linkcolor=darkblue,urlcolor=darkblue, + anchorcolor=darkblue,citecolor=darkblue} + +\usepackage{a4wide} + +\begin{document} +\title{A Manual for Armed Bear Common Lisp} +\date{June 15, 2011} +\author{Mark Evenson, Erik Huelsmann, Alessio Stallo, Ville Voutilainen} + +\section{Introduction} +\subsection{Version} + +This manual corresponds to abcl-0.26.0, as yet unreleased. + +\section{Obtaining} + +\subsection{Requirements} + +java-1.5.xx, java-1.6.0_10+ recommended. + +\subsection{Building from Source} +% TODO repeat install + +\subsection{Contributing} + +\section{Interaction with host JVM} + +% describe calling Java from Lisp, and calling Lisp from Java, +% probably in two separate sections. Presumably, we can partition our +% audience into those who are more comfortable with Java, and those +% that are more comforable with Lisp + +\subsection{Lisp to Java} + +\subsection{Lisp from Java} + +\subsection{JAVA} + +% include autogen docs for the JAVA package. + +\section{ANSI Common Lisp Conformance} + +ABCL is currently a non-conforming ANSI Common Lisp implementation due +to the following (known) issues: + +\begin{itemize} + \item Lack of long form of DEFINE-METHOD-COMBINATION + \item Missing statement of conformance in accompanying documentation + \item Incomplete MOP + % TODO go through AMOP with symbols, starting by looking for + % matching function signature. +\end{itemize} + +ABCL aims to be be a fully conforming ANSI Common Lisp +implementation. Any other behavior should be reported as a bug. + +\section{Extensions} + +% TODO document the EXTENSIONS package. + +\section{Multithreading} + +% TODO document the THREADS package. + +\section{History} + +\end{document} From mevenson at common-lisp.net Thu Jun 16 05:25:25 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 15 Jun 2011 22:25:25 -0700 Subject: [armedbear-cvs] r13332 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jun 15 22:25:24 2011 New Revision: 13332 Log: Expand the Java docstring annotation to include a separate field for return values. The use of the "arg1 arg1 => return-value1, [return-value2 ...]" caused problems with interpolating the value of the DocString.args as a list of symbols as the commas have no matching backquote operator. Modified: trunk/abcl/src/org/armedbear/lisp/DocString.java Modified: trunk/abcl/src/org/armedbear/lisp/DocString.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/DocString.java Wed Jun 15 11:17:12 2011 (r13331) +++ trunk/abcl/src/org/armedbear/lisp/DocString.java Wed Jun 15 22:25:24 2011 (r13332) @@ -45,6 +45,8 @@ public String name() default ""; /** The arguments. */ public String args() default ""; + /** The return value(s) of a function */ + public String returns() default ""; /** The documentation string. */ public String doc() default ""; } From mevenson at common-lisp.net Thu Jun 16 05:25:44 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 15 Jun 2011 22:25:44 -0700 Subject: [armedbear-cvs] r13333 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jun 15 22:25:43 2011 New Revision: 13333 Log: Fix hashtable associated docstrings. These were both a) not assigned to the class and b) failed to properly interpolate values for ARGSLIST. Modified: trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Wed Jun 15 22:25:24 2011 (r13332) +++ trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Wed Jun 15 22:25:43 2011 (r13333) @@ -46,9 +46,9 @@ static final LispObject FUNCTION_EQUALP = Symbol.EQUALP.getSymbolFunction(); - @DocString(name="%make-hash-table") private static final Primitive _MAKE_HASH_TABLE = new pf__make_hash_table(); + @DocString(name="%make-hash-table") private static final class pf__make_hash_table extends Primitive { pf__make_hash_table() { super("%make-hash-table", PACKAGE_SYS, false); @@ -73,10 +73,10 @@ } }; - @DocString(name="%make-weak-hash-table") + private static final Primitive _MAKE_WEAK_HASH_TABLE = new pf__make_weak_hash_table(); - + @DocString(name="%make-weak-hash-table") private static final class pf__make_weak_hash_table extends Primitive { pf__make_weak_hash_table() { super("%make-weak-hash-table", PACKAGE_SYS, false); @@ -106,11 +106,12 @@ } }; - @DocString(name="gethash", - args="key hash-table &optional default => value, present-p", - doc="Returns the value associated with KEY in HASH-TABLE.") private static final Primitive GETHASH = new pf_gethash(); + @DocString(name="gethash", + args="key hash-table &optional default", + returns="value, present-p", + doc="Returns the value associated with KEY in HASH-TABLE.") private static final class pf_gethash extends Primitive { pf_gethash() { super(Symbol.GETHASH, "key hash-table &optional default"); @@ -137,10 +138,10 @@ } }; - @DocString(name="gethash1", - args="key hash-table => value") private static final Primitive GETHASH1 = new pf_gethash1(); + @DocString(name="gethash1", + args="key hash-table", returns="value") private static final class pf_gethash1 extends Primitive { pf_gethash1() { super(Symbol.GETHASH1, "key hash-table"); @@ -163,12 +164,10 @@ } }; - // ### puthash key hash-table new-value &optional default => value - @DocString(name="puthash", - args="key hash-table new-value &optional default => value") private static final Primitive PUTHASH = new pf_puthash(); - + @DocString(name="puthash", + args="key hash-table new-value &optional default", returns="value") private static final class pf_puthash extends Primitive { pf_puthash() { super(Symbol.PUTHASH, @@ -194,11 +193,11 @@ } }; - @DocString(name="remhash", - args="key hash-table => generalized-boolean", - doc="Removes the value for KEY in HASH-TABLE, if any.") private static final Primitive REMHASH = new pf_remhash(); + @DocString(name="remhash", + args="key hash-table", returns="generalized-boolean", + doc="Removes the value for KEY in HASH-TABLE, if any.") private static final class pf_remhash extends Primitive { pf_remhash() { super(Symbol.REMHASH, "key hash-table"); @@ -212,10 +211,10 @@ } }; - @DocString(name="clrhash", - args="hash-table => hash-table") private static final Primitive CLRHASH = new pf_clrhash(); + @DocString(name="clrhash", + args="hash-table", returns="hash-table") private static final class pf_clrhash extends Primitive { pf_clrhash() { super(Symbol.CLRHASH, "hash-table"); @@ -232,11 +231,11 @@ } }; + private static final Primitive HASH_TABLE_COUNT + = new pf_hash_table_count(); @DocString(name="hash-table-count", args="hash-table", doc="Returns the number of entries in HASH-TABLE.") - private static final Primitive HASH_TABLE_COUNT - = new pf_hash_table_count(); private static final class pf_hash_table_count extends Primitive { pf_hash_table_count() { super(Symbol.HASH_TABLE_COUNT, "hash-table"); @@ -251,10 +250,10 @@ } }; - @DocString(name="sxhash", - args="object => hash-code") private static final Primitive SXHASH = new pf_sxhash(); + @DocString(name="sxhash", + args="object => hash-code") private static final class pf_sxhash extends Primitive { pf_sxhash() { super(Symbol.SXHASH, "object"); @@ -282,11 +281,11 @@ } }; + private static final Primitive HASH_TABLE_P + = new pf_hash_table_p(); @DocString(name="hash-table-p", args="object", doc="Whether OBJECT is an instance of a hash-table.") - private static final Primitive HASH_TABLE_P - = new pf_hash_table_p(); private static final class pf_hash_table_p extends Primitive { pf_hash_table_p(){ super(Symbol.HASH_TABLE_P,"object"); @@ -299,11 +298,11 @@ } }; + private static final Primitive HASH_TABLE_ENTRIES + = new pf_hash_table_entries(); @DocString(name="hah-table-entries", args="hash-table", doc="Returns a list of all key/values pairs in HASH-TABLE.") - private static final Primitive HASH_TABLE_ENTRIES - = new pf_hash_table_entries(); private static final class pf_hash_table_entries extends Primitive { pf_hash_table_entries() { super("hash-table-entries", PACKAGE_SYS, false); @@ -318,11 +317,11 @@ } }; + private static final Primitive HASH_TABLE_TEST + = new pf_hash_table_test(); @DocString(name="hash-table-test", args="hash-table", doc="Return the test used for the keys of HASH-TABLE.") - private static final Primitive HASH_TABLE_TEST - = new pf_hash_table_test(); private static final class pf_hash_table_test extends Primitive { pf_hash_table_test() { super(Symbol.HASH_TABLE_TEST, "hash-table"); @@ -336,11 +335,11 @@ } }; + private static final Primitive HASH_TABLE_SIZE + = new pf_hash_table_size(); @DocString(name="hash-table-size", args="hash-table", doc="Returns the number of storage buckets in HASH-TABLE.") - private static final Primitive HASH_TABLE_SIZE - = new pf_hash_table_size(); private static final class pf_hash_table_size extends Primitive { pf_hash_table_size() { super(Symbol.HASH_TABLE_SIZE, "hash-table"); @@ -355,10 +354,10 @@ } }; - @DocString(name="hash-table-rehash-size", - args="hash-table") private static final Primitive HASH_TABLE_REHASH_SIZE = new pf_hash_table_rehash_size(); + @DocString(name="hash-table-rehash-size", + args="hash-table") private static final class pf_hash_table_rehash_size extends Primitive { pf_hash_table_rehash_size() { super(Symbol.HASH_TABLE_REHASH_SIZE, "hash-table"); @@ -373,10 +372,10 @@ } }; - @DocString(name="hash-table-rehash-threshold", - args="hash-table") private static final Primitive HASH_TABLE_REHASH_THRESHOLD = new pf_hash_table_rehash_threshold(); + @DocString(name="hash-table-rehash-threshold", + args="hash-table") private static final class pf_hash_table_rehash_threshold extends Primitive { pf_hash_table_rehash_threshold() { super(Symbol.HASH_TABLE_REHASH_THRESHOLD, "hash-table"); @@ -391,13 +390,13 @@ } }; + private static final Primitive MAPHASH + = new pf_maphash(); @DocString(name="maphash", args="function hash-table", doc="Iterates over all entries in the hash-table. For each entry," + " the function is called with two arguments--the key and the" + " value of that entry.") - private static final Primitive MAPHASH - = new pf_maphash(); private static final class pf_maphash extends Primitive { pf_maphash() { super(Symbol.MAPHASH, "function hash-table"); @@ -412,11 +411,11 @@ } }; + private static final Primitive HASH_TABLE_WEAKNESS + = new pf_hash_table_weakness(); @DocString(name="hash-table-weakness", args="hash-table", doc="Return weakness property of HASH-TABLE, or NIL if it has none.") - private static final Primitive HASH_TABLE_WEAKNESS - = new pf_hash_table_weakness(); private static final class pf_hash_table_weakness extends Primitive { pf_hash_table_weakness() { super(Symbol.HASH_TABLE_WEAKNESS, "hash-table"); From mevenson at common-lisp.net Thu Jun 16 05:53:01 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 15 Jun 2011 22:53:01 -0700 Subject: [armedbear-cvs] r13334 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Wed Jun 15 22:53:00 2011 New Revision: 13334 Log: Start outlining highlights of Lisp's interactions with Java. Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Wed Jun 15 22:25:43 2011 (r13333) +++ trunk/abcl/doc/manual/abcl.tex Wed Jun 15 22:53:00 2011 (r13334) @@ -1,3 +1,8 @@ +% TODO +% 1. Create mechanism for swigging DocString and Lisp docs into +% sections. + + \documentclass[10pt]{article} \usepackage{color,hyperref} @@ -10,7 +15,7 @@ \begin{document} \title{A Manual for Armed Bear Common Lisp} -\date{June 15, 2011} +\date{June 16, 2011} \author{Mark Evenson, Erik Huelsmann, Alessio Stallo, Ville Voutilainen} \section{Introduction} @@ -38,8 +43,40 @@ \subsection{Lisp to Java} +ABCL offers a number of mechanisms to manipulate Java libraries from +Lisp. + +\begin{itemize} +\item Java values are accessible as objects of type JAVA:JAVA-OBJECT. +\item The Java FFI presents a Lisp package (JAVA) with many useful + symbols for manipulating the artifacts of executation on the JVM, + including creation of new objects (JAVA:JNEW, JAVA:JMETHOD), the + introspection of values (JAVA:JFIELD), the execution of methods + (JAVA:JCALL, JAVA:JCALL-RAW, JAVA:JSTATIC) +\item The JSS package (JSS) in contrib introduces a convenient macro + syntax (JSS:SHARPSIGN_HASH_DOUBLQUOTE_MACRO) for accessing Java + methods, and additional convenience funtions. +\item Java classes and libraries may be dynamically added to the + classpath at runtime (JAVA:ADD-TO-CLASSPATH). +\end{itemize} + \subsection{Lisp from Java} +Manipulation of the Lisp API is currently lacking a stable interface, +so what is documented here is subject to change. + +\begin{itemize} +\item All Lisp values are descendents of LispObject.java +\item Lisp symbols are accessible via either directly referening the + Symbol.java instance or by dynamically introspecting the + corresponding Package.java instance. +\item The Lisp dynamic envrionment may be saved via + LispThread.bindSpecial(BINDING) and restored via + LispThread.resetSpecialBindings(mark). +\item Functions may be executed by invocation of the + Function.execute(args [...]) +\end{itemize} + \subsection{JAVA} % include autogen docs for the JAVA package. From mevenson at common-lisp.net Thu Jun 16 14:56:44 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 16 Jun 2011 07:56:44 -0700 Subject: [armedbear-cvs] r13335 - in trunk/abcl/doc: . manual Message-ID: Author: mevenson Date: Thu Jun 16 07:56:43 2011 New Revision: 13335 Log: Fold freestanding documentation into the Manual. Deleted: trunk/abcl/doc/lisp-ffi.markdown Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Wed Jun 15 22:53:00 2011 (r13334) +++ trunk/abcl/doc/manual/abcl.tex Thu Jun 16 07:56:43 2011 (r13335) @@ -77,6 +77,141 @@ Function.execute(args [...]) \end{itemize} +\subsubsection{Lisp FFI} + +FFI stands for "Foreign Function Interface", which is the way the +contemporary Lisp world refers to methods of "calling out" from Lisp +into "foreign" langauges and envrionments. This document describes +the various ways that one interacts with Lisp world of Abcl from Java, +considering the hosted Lisp as the "Foreign Function" that needs to be +"Interfaced". + + +\subsubsubsection{Calling Lisp from Java} + +Note: As the entire ABCL Lisp system resides in the org.armedbear.lisp +package the following code snippets do not show the relevant import +statements in the interest of brevity. + +Per JVM, there can only ever be a single Lisp interpreter. This is +started by calling the static method `Interpreter.createInstance()`. + +\begin{code}{java} +Interpreter interpreter = Interpreter.createInstance(); +\end{code} + +If this method has already been invoked in the lifetime of the current +Java process it will return null, so if you are writing Java whose +lifecycle is a bit out of your control (like in a Java servlet), a +safer invocation pattern might be: + +\begin{code}{java} +Interpreter interpreter = Interpreter.getInstance(); +if (interpreter == null) { + interpreter = Interpreter.createInstance(); +} +\end{code} + + + +The Lisp `EVAL` primitive may be simply passed strings for evaluation, +as follows + +\begin{code}{java} +String line = "(load \"file.lisp\")"; +LispObject result = interpreter.eval(line); +\end{code} + + +Notice that all possible return values from an arbitrary Lisp +computation are collapsed into a single return value. Doing useful +further computation on the `LispObject` depends on knowing what the +result of the computation might be, usually involves some amount +of instanceof introspection, and forms a whole topic to itself +(c.f. [Introspecting a LispObject](#introspecting)). + +Using `EVAL` involves the Lisp interpreter. Lisp functions may be +directly invoked by Java method calls as follows. One simply locates +the package containing the symbol, then obtains a reference to the +symbol, and then invokes the `execute()` method with the desired +parameters. + +\begin{code}{java} + interpreter.eval("(defun foo (msg) (format nil \"You told me '~A'~%\" msg))"); + Package pkg = Packages.findPackage("CL-USER"); + Symbol foo = pkg.findAccessibleSymbol("FOO"); + Function fooFunction = (Function)foo.getSymbolFunction(); + JavaObject parameter = new JavaObject("Lisp is fun!"); + LispObject result = fooFunction.execute(parameter); + // How to get the "naked string value"? + System.out.prinln("The result was " + result.writeToString()); +\end{code} + +If one is calling an primitive function in the CL package the syntax +becomes considerably simpler if we can locate the instance of +definition in the ABCL source, we can invoke the symbol directly. To +tell if a `LispObject` contains a reference to a symbol. + +\begin{code}{java} + boolean nullp(LispObject object) { + LispObject result = Primitives.NULL.execute(object); + if (result == NIL) { + return false; + } + return true; + } + +\end{code} + +/subsubsubsection{Introspecting a LispObject} + +We present various patterns for introspecting an an arbitrary +`LispObject` which can represent the result of every Lisp evaluation +into semantics that Java can meaniningfully deal with. + +/subsubsubsubsection{LispObject as \java{boolean}} + +If the LispObject a generalized boolean values, one can use +\java{getBooleanValue()} to convert to Java: + +\begin{code}{java} + LispObject object = Symbol.NIL; + boolean javaValue = object.getBooleanValue(); +\end{code} + +Although since in Lisp, any value other than NIL means "true", the +use of Java equality it quite a bit easier and more optimal: + +\begin{code}{java} + boolean javaValue = (object != Symbol.NIL); +\end{code} + +/subsubsubsubsection{LispObject is a list} + +If LispObject is a list, it will have the type `Cons`. One can then use +the `copyToArray[]` to make things a bit more suitable for Java +iteration. + +\begin{code}{java} + LispObject result = interpreter.eval("'(1 2 4 5)"); + if (result instanceof Cons) { + LispObject array[] = ((Cons)result.copyToArray()); + ... + } +\end{code} + +A more Lispy way to iterated down a list is to use the `cdr()` access +function just as like one would traverse a list in Lisp:; + +\begin{code}{java} + LispObject result = interpreter.eval("'(1 2 4 5)"); + while (result != Symbol.NIL) { + doSomething(result.car()); + result = result.cdr(); + } +\end{code} + + \subsection{JAVA} % include autogen docs for the JAVA package. From mevenson at common-lisp.net Thu Jun 16 14:56:53 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 16 Jun 2011 07:56:53 -0700 Subject: [armedbear-cvs] r13336 - in trunk/abcl: . contrib/asdf-jar src/org/armedbear/lisp src/org/armedbear/lisp/protocol test/lisp/abcl Message-ID: Author: mevenson Date: Thu Jun 16 07:56:53 2011 New Revision: 13336 Log: Create form of SYSTEM:ZIP that uses a hashtable to map files to entries. SYSTEM:ZIP PATH HASHTABLE now creates entries in a zipfile at PATH whose entries are the contents of for each (KEY VALUE) in HASHTABLE for which KEY refers to an object on the filesystem and VALUE is the location in the zip archive. Introduce Java interfaces in org.armedbear.lisp.protocol to start encapsulating behavior of Java system. By retroactively adding markers to the object hierarchy rooted on LispObject we gain the ability to have our JVM code optionally work with interfaces but we leave the core dispatch functions alone for speed. Added: trunk/abcl/src/org/armedbear/lisp/protocol/ trunk/abcl/src/org/armedbear/lisp/protocol/Hashtable.java trunk/abcl/src/org/armedbear/lisp/protocol/Inspectable.java trunk/abcl/src/org/armedbear/lisp/protocol/LispObject.java trunk/abcl/test/lisp/abcl/zip.lisp Modified: trunk/abcl/abcl.asd trunk/abcl/contrib/asdf-jar/asdf-jar.lisp trunk/abcl/src/org/armedbear/lisp/HashTable.java trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java trunk/abcl/src/org/armedbear/lisp/zip.java Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd Thu Jun 16 07:56:43 2011 (r13335) +++ trunk/abcl/abcl.asd Thu Jun 16 07:56:53 2011 (r13336) @@ -57,6 +57,8 @@ ("file-system-tests")) #+abcl (:file "weak-hash-tables") + #+abcl + (:file "zip") #+abcl (:file "pathname-tests" :depends-on ("utilities")))))) Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Thu Jun 16 07:56:43 2011 (r13335) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Thu Jun 16 07:56:53 2011 (r13336) @@ -4,29 +4,93 @@ (in-package :asdf-jar) + (defvar *systems*) (defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system)) (push c *systems*)) -(defun package (system-name &key (recursive t) (verbose t)) - (declare (ignore recursive)) +;; (defvar *sources*) +;; (defmethod asdf:perform :before ((op asdf:compile-op) (s asdf:source-file)) +;; (push c *sources*)) + +(eval-when (:compile-toplevel :execute) + (ql:quickload "cl-fad")) + +(defun package (system-name + &key (out #p"/var/tmp/") + (recursive t) + (verbose t)) (asdf:disable-output-translations) - (let* ((system (asdf:find-system system-name)) - (name (slot-value system 'asdf::name))) + (let* ((system + (asdf:find-system system-name)) + (name + (slot-value system 'asdf::name)) + (version + (slot-value system 'asdf:version)) + (package-jar-name + (format nil "~A~A-~A.jar" name (when recursive "-all") version)) + (package-jar + (make-pathname :directory out :defaults package-jar-name)) + (tmpdir (tmpdir (pathname-name (pathname package-jar-name))))) (when verbose - (format verbose "Packaging ASDF definition of~A~%" system)) + (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar)) (setf *systems* nil) (asdf:compile-system system :force t) (let* ((dir (asdf:component-pathname system)) (wild-contents (merge-pathnames "**/*" dir)) (contents (directory wild-contents)) - (output (format nil "/var/tmp/~A.jar" name)) (topdir (truename (merge-pathnames "../" dir)))) (when verbose - (format verbose "Packaging contents in ~A.~%" output)) - (system:zip output contents topdir))) + (format verbose "~&Packaging contents in ~A." package-jar)) + (dolist (system (append (list system) *systems*)) + (copy-recursively system tmpdir)) + (system:zip package-jar contents topdir))) (asdf:initialize-output-translations)) +(defun copy-recursively (source destination) + (let* ((source (truename source)) + (source-directories (1- (length (pathname-directory source)))) + (destination (truename destination))) + (cl-fad:walk-directory + source + (lambda (p) + (let* ((relative-depth (- (length (pathname-directory p)) + (length (pathname-directory source)))) + (subdir '(nthcdr (+ source-directories relative-depth) + (pathname-directory source))) + (orig (merge-pathnames p + (make-pathname :directory (append (pathname-directory + source) + subdir)))) + (dest (merge-pathnames p + (make-pathname :directory (append (pathname-directory + destination) + subdir))))) + (format t "~&Would copy ~A~&to ~A." orig dest)))))) + + +(defun tmpdir (name) + "Return a the named temporary directory." + (let* ((temp-file (java:jcall "getAbsolutePath" + (java:jstatic "createTempFile" "java.io.File" "foo" "tmp"))) + (temp-path (pathname temp-file))) + (make-pathname + :directory (nconc (pathname-directory temp-path) + (list name))))) + + + + + + + + + + + + + + Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java Thu Jun 16 07:56:43 2011 (r13335) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Thu Jun 16 07:56:53 2011 (r13336) @@ -36,7 +36,10 @@ import java.util.concurrent.locks.ReentrantLock; import static org.armedbear.lisp.Lisp.*; -public class HashTable extends LispObject { +public class HashTable + extends LispObject + implements org.armedbear.lisp.protocol.Hashtable +{ protected static final float loadFactor = 0.75f; protected final LispObject rehashSize; @@ -347,8 +350,13 @@ } } - // Returns a list of (key . value) pairs. + public LispObject ENTRIES() { + return getEntries(); + } + + // Returns a list of (key . value) pairs. + public LispObject getEntries() { // No need to take out a read lock, for the same reason as MAPHASH HashEntry[] b = buckets; LispObject list = NIL; Modified: trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Thu Jun 16 07:56:43 2011 (r13335) +++ trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Thu Jun 16 07:56:53 2011 (r13336) @@ -57,6 +57,7 @@ // WeakHashTable type to be parameterized on an enclosed type. public class WeakHashTable extends LispObject + implements org.armedbear.lisp.protocol.Hashtable { protected static final float loadFactor = 0.75f; protected final LispObject rehashSize; @@ -508,8 +509,13 @@ } } - // Returns a list of (key . value) pairs. + @Deprecated public LispObject ENTRIES() { + return getEntries(); + } + + /** @returns A list of (key . value) pairs. */ + public LispObject getEntries() { HashEntry[] b = getTable(); LispObject list = NIL; for (int i = b.length; i-- > 0;) { Added: trunk/abcl/src/org/armedbear/lisp/protocol/Hashtable.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/protocol/Hashtable.java Thu Jun 16 07:56:53 2011 (r13336) @@ -0,0 +1,11 @@ +package org.armedbear.lisp.protocol; + +/** Mark object as implementing the Hashtable protocol. */ +public interface Hashtable + extends org.armedbear.lisp.protocol.LispObject +{ + public org.armedbear.lisp.LispObject getEntries(); + + @Deprecated + public org.armedbear.lisp.LispObject ENTRIES(); +} \ No newline at end of file Added: trunk/abcl/src/org/armedbear/lisp/protocol/Inspectable.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/protocol/Inspectable.java Thu Jun 16 07:56:53 2011 (r13336) @@ -0,0 +1,7 @@ +package org.armedbear.lisp.protocol; + +/** Object implements a protocol for dynamic introspection. */ +public interface Inspectable { + public org.armedbear.lisp.LispObject getParts(); +} + Added: trunk/abcl/src/org/armedbear/lisp/protocol/LispObject.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/protocol/LispObject.java Thu Jun 16 07:56:53 2011 (r13336) @@ -0,0 +1,8 @@ +package org.armedbear.lisp.protocol; + +/** Mark implementation of the LispObject protocol. */ +public interface LispObject { + public org.armedbear.lisp.LispObject typeOf(); + // TODO fill in with other functions as need arises +} + Modified: trunk/abcl/src/org/armedbear/lisp/zip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/zip.java Thu Jun 16 07:56:43 2011 (r13335) +++ trunk/abcl/src/org/armedbear/lisp/zip.java Thu Jun 16 07:56:53 2011 (r13336) @@ -58,11 +58,15 @@ { super("zip", PACKAGE_SYS, true); } + @Override public LispObject execute(LispObject first, LispObject second) { Pathname zipfilePathname = coerceToPathname(first); + if (second instanceof org.armedbear.lisp.protocol.Hashtable) { + return execute(zipfilePathname, (org.armedbear.lisp.protocol.Hashtable)second); + } byte[] buffer = new byte[4096]; try { String zipfileNamestring = zipfilePathname.getNamestring(); @@ -80,8 +84,8 @@ out.close(); File zipfile = new File(zipfileNamestring); zipfile.delete(); - return error(new SimpleError("Pathname has no namestring: " + - pathname.writeToString())); + return error(new SimpleError("Pathname has no namestring: " + + pathname.writeToString())); } File file = new File(namestring); makeEntry(out, file); @@ -95,6 +99,8 @@ return zipfilePathname; } + + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) { @@ -154,6 +160,82 @@ } return zipfilePathname; } + + static class Directories extends HashSet { + private Directories() { + super(); + } + + ZipOutputStream out; + public Directories(ZipOutputStream out) { + this.out = out; + } + + public void ensure(String path) + throws IOException + { + int i = 0; + int j; + while ((j = path.indexOf(Pathname.separator, i)) != -1) { + i = j + 1; + final String directory = path.substring(0, j) + Pathname.separator; + if (!contains(directory)) { + add(directory); + ZipEntry entry = new ZipEntry(directory); + out.putNextEntry(entry); + out.closeEntry(); + } + } + } + } + + public LispObject execute(final Pathname zipfilePathname, final org.armedbear.lisp.protocol.Hashtable table) { + LispObject entriesObject = (LispObject)table.getEntries(); + if (!(entriesObject instanceof Cons)) { + return NIL; + } + Cons entries = (Cons)entriesObject; + + String zipfileNamestring = zipfilePathname.getNamestring(); + if (zipfileNamestring == null) + return error(new SimpleError("Pathname has no namestring: " + + zipfilePathname.writeToString())); + ZipOutputStream out = null; + try { + out = new ZipOutputStream(new FileOutputStream(zipfileNamestring)); + } catch (FileNotFoundException e) { + return error(new FileError("Failed to create file for writing zip archive", zipfilePathname)); + } + Directories directories = new Directories(out); + + + for (LispObject head = entries; head != NIL; head = head.cdr()) { + final LispObject key = head.car().car(); + final LispObject value = head.car().cdr(); + + final Pathname source = Lisp.coerceToPathname(key); + final Pathname destination = Lisp.coerceToPathname(value); + final File file = Utilities.getFile(source); + try { + String jarEntry = destination.getNamestring(); + if (jarEntry.startsWith("/")) { + jarEntry = jarEntry.substring(1); + } + directories.ensure(jarEntry); + makeEntry(out, file, jarEntry); + } catch (FileNotFoundException e) { + return error(new FileError("Failed to read file for incoporation in zip archive.", source)); + } catch (IOException e) { + return error(new FileError("Failed to add file to zip archive.", source)); + } + } + try { + out.close(); + } catch (IOException ex) { + return error(new FileError("Failed to close zip archive.", zipfilePathname)); + } + return zipfilePathname; + } private static final Primitive zip = new zip(); Added: trunk/abcl/test/lisp/abcl/zip.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/test/lisp/abcl/zip.lisp Thu Jun 16 07:56:53 2011 (r13336) @@ -0,0 +1,20 @@ +(in-package #:abcl.test.lisp) + +(deftest zip.1 + (let ((mapping (make-hash-table :test 'equal))) + (loop :for (key value) + :in `(("/etc/hosts" "/etc/hosts") + ("/etc/group" "groups") + ("/etc/resolv.conf" "/opt/etc/resolv.conf")) + :doing + (setf (gethash key mapping) value)) + (values + (system:zip #p"/var/tmp/foo.jar" mapping) + (not (probe-file "jar:file:/var/tmp/foo.jar!/etc/hosts")) + (not (probe-file "jar:file:/var/tmp/foo.jar!/groups")) + (not (probe-file "jar:file:/var/tmp/foo.jar!/opt/etc/resolv.conf")))) + #p"/var/tmp/foo.jar" nil nil nil) + +(eval-when (:load-toplevel) + (if (not (find :unix *features*)) + (pushnew 'zip.1 *expected-failures*))) From mevenson at common-lisp.net Thu Jun 16 15:02:11 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 16 Jun 2011 08:02:11 -0700 Subject: [armedbear-cvs] r13337 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Thu Jun 16 08:02:11 2011 New Revision: 13337 Log: HEADS-UP breaks package. Intermediate checkpoint on the road to fully working with the new interface for SYSTEM:ZIP that shouldn't require any temporary directory. Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Thu Jun 16 07:56:53 2011 (r13336) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Thu Jun 16 08:02:11 2011 (r13337) @@ -7,20 +7,12 @@ (defvar *systems*) (defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system)) - (push c *systems*)) - -;; (defvar *sources*) -;; (defmethod asdf:perform :before ((op asdf:compile-op) (s asdf:source-file)) -;; (push c *sources*)) - -(eval-when (:compile-toplevel :execute) - (ql:quickload "cl-fad")) + (push c *systems*)) (defun package (system-name &key (out #p"/var/tmp/") (recursive t) (verbose t)) - (asdf:disable-output-translations) (let* ((system (asdf:find-system system-name)) (name @@ -31,7 +23,7 @@ (format nil "~A~A-~A.jar" name (when recursive "-all") version)) (package-jar (make-pathname :directory out :defaults package-jar-name)) - (tmpdir (tmpdir (pathname-name (pathname package-jar-name))))) + (mapping (make-hash-table :test 'equal))) (when verbose (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar)) (setf *systems* nil) @@ -43,34 +35,23 @@ (when verbose (format verbose "~&Packaging contents in ~A." package-jar)) (dolist (system (append (list system) *systems*)) - (copy-recursively system tmpdir)) - (system:zip package-jar contents topdir))) - (asdf:initialize-output-translations)) - -(defun copy-recursively (source destination) - (let* ((source (truename source)) - (source-directories (1- (length (pathname-directory source)))) - (destination (truename destination))) - (cl-fad:walk-directory - source - (lambda (p) - (let* ((relative-depth (- (length (pathname-directory p)) - (length (pathname-directory source)))) - (subdir '(nthcdr (+ source-directories relative-depth) - (pathname-directory source))) - (orig (merge-pathnames p - (make-pathname :directory (append (pathname-directory - source) - subdir)))) - (dest (merge-pathnames p - (make-pathname :directory (append (pathname-directory - destination) - subdir))))) - (format t "~&Would copy ~A~&to ~A." orig dest)))))) - + (let ((base (slot-value system 'asdf:absolute-pathname)) + (name (slot-value system 'asdf:name)) + (asdf (slot-value system source-file))) + (setf (gethash asdf mapping) (relative-path base name asdf)))) + ;;; XXX iterate through the rest of the contents of the + ;;; system, adding appropiate entries + (system:zip package-jar mapping)))) + +(defun relative-path (base dir file) + (let* ((relative + (nthcdr (length (pathname-directory base)) (pathname-directory file))) + (entry-dir `(:relative ,dir ,@(when relative relative)))) + (make-pathname :directory entry-dir + :defaults file))) (defun tmpdir (name) - "Return a the named temporary directory." + "Return temporary directory." (let* ((temp-file (java:jcall "getAbsolutePath" (java:jstatic "createTempFile" "java.io.File" "foo" "tmp"))) (temp-path (pathname temp-file))) From mevenson at common-lisp.net Fri Jun 17 07:01:11 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 00:01:11 -0700 Subject: [armedbear-cvs] r13338 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Fri Jun 17 00:01:10 2011 New Revision: 13338 Log: Add installation instructions. HEADS-UP: This file is guaranteed not to compile in any LaTeX system without further substantial work, as I am defining the DSL I want for doumentation as I go, trying out different syntaxes. Separate content/presentation rules via LaTeX include directives. Properly use the as yet unwritten \code{} markup. The 'java.tex', 'threads.tex', and 'extensions.tex' are placeholders until we get the automatic documentation generator working. Added: trunk/abcl/doc/manual/extensions.tex trunk/abcl/doc/manual/index.sty trunk/abcl/doc/manual/java.tex trunk/abcl/doc/manual/threads.tex Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Thu Jun 16 08:02:11 2011 (r13337) +++ trunk/abcl/doc/manual/abcl.tex Fri Jun 17 00:01:10 2011 (r13338) @@ -1,21 +1,10 @@ -% TODO -% 1. Create mechanism for swigging DocString and Lisp docs into -% sections. - - -\documentclass[10pt]{article} +% http://en.wikibooks.org/wiki/LaTeX/ -\usepackage{color,hyperref} -\definecolor{darkblue}{rgb}{0.0,0.0,0.3} -\hypersetup{colorlinks,breaklinks, - linkcolor=darkblue,urlcolor=darkblue, - anchorcolor=darkblue,citecolor=darkblue} - -\usepackage{a4wide} +\include{index.sty} \begin{document} \title{A Manual for Armed Bear Common Lisp} -\date{June 16, 2011} +\date{June 17, 2011} \author{Mark Evenson, Erik Huelsmann, Alessio Stallo, Ville Voutilainen} \section{Introduction} @@ -25,12 +14,141 @@ \section{Obtaining} +\subsection{Source Repositories} + +\begin[shell]{code} + svn co http://svn.common-lisp.net/armedbear/trunk abcl +\end{code} + \subsection{Requirements} java-1.5.xx, java-1.6.0_10+ recommended. \subsection{Building from Source} -% TODO repeat install + +There are three ways to build ABCL from the source release with the +preferred (and most tested way) is to being to use the Ant build tool: + +\begin{itemize} + +\item Use the Ant build tool for Java environments. + +\item Use the Netbeans 6.x IDE to open ABCL as a project. + +\item Bootstrap ABCL using a Common Lisp implementation. Supported + implementations for this process: SBCL, CMUCL, OpenMCL, Allegro + CL, LispWorks or CLISP. +\end{itemize} + +In all cases you need a Java 5 or later JDK (JDK 1.5 and 1.6 have been +tested). Just the JRE isn't enough, as you need the Java compiler +('javac') to compile the Java source of the ABCL implementation. + +Note that when deploying ABCL having JDK isn't a requirement for the +installation site, just the equivalent JRE, as ABCL compiles directly +to byte code, avoiding the need for the 'javac' compiler in deployment +environments. + + +\subsubsection{Using Ant} + +Download a binary distribution [Ant version 1.7.1 or greater][1]. +Unpack the files somewhere convenient, ensuring that the 'ant' (or +'ant.bat' under Windows) executable is in your path and executable. + +[1]: http://ant.apache.org/bindownload.cgi + +Then simply executing + +\begin[shell]{code} + unix$ ant +\end{code} + +or + +\begin[shell]{code} + dos> ant.bat +\end{code} + +from the directory containing this README file will create an +executable wrapper ('abcl' under UNIX, 'abcl.bat' under Windows). Use +this wrapper to start ABCL. + + +\subsubsection{Using NetBeans} + +Obtain and install the [Netbeans IDE][2]. One should be able to open +the ABCL directory as a project in the Netbeans 6.x application, +whereupon the usual build, run, and debug targets as invoked in the +GUI are available. + +[2]: http://netbeans.org/downloads/ + + +\subsubsection{Building from Lisp} + + +Building from a Lisp is the most venerable and untested way of +building ABCL. It produces a "non-standard" version of the +distribution that doesn't share build instructions with the previous +two methods, but it still may be of interest to those who absolutely +don't want to know anything about Java. + +First, copy the file 'customizations.lisp.in' to 'customization.lisp', +in the directory containing this README file, editing to suit your +situation, paying attention to the comments in the file. The critical +step is to have Lisp special variable '*JDK*' point to the root of the +Java Development Kit. Underneath the directory referenced by the +value of '*JDK*' there should be an exectuable Java compiler in +'bin/javac' ('bin/java.exe' under Windows). + +Then, one may either use the 'build-from-lisp.sh' shell script or load +the necessary files into your Lisp image by hand. + +\paragraph{Using the 'build-from-lisp.sh' script} + +Under UNIX-like systems, you may simply invoke the +'build-from-lisp.sh' script as './build-from-lisp.sh +', e.g. + +\begin[shell]{code} + unix$ ./build-from-lisp.sh sbcl +\end{code} + +After a successful build, you may use \file{abcl} (\file{abcl.bat} on +Windows) to start ABCL. Note that this wrappers contain absolute +paths, so you'll need to edit them if you move things around after the +build. + +If you're developing on ABCL, you may want to use + +\begin[shell]{code} + unix$ ./build-from-lisp.sh --clean=nil +\end{code} + +to not do a full rebuild. + +In case of failure in the javac stage, you might try this: + +\begin[shell]{code} + unix$ ./build-from-lisp.sh --full=t --clean=t --batch=nil +\end{code} + +This invokes javac separately for each .java file, which avoids running +into limitations on command line length (but is a lot slower). + +\subsubsubsection{Building from another Lisp by hand} + +There is also an ASDF definition in 'abcl.asd' for the BUILD-ABCL +which can be used to load the necessary Lisp definitions, after which + +\begin[lisp]{code} + CL-USER> (build-abcl:build-abcl :clean t :full t) +\end{code} + +will build ABCL. If ASDF isn't present, simply LOAD the +'customizations.lisp' and 'build-abcl.lisp' files to achieve the same +effect as loading the ASDF definition. \subsection{Contributing} @@ -49,13 +167,13 @@ \begin{itemize} \item Java values are accessible as objects of type JAVA:JAVA-OBJECT. \item The Java FFI presents a Lisp package (JAVA) with many useful - symbols for manipulating the artifacts of executation on the JVM, - including creation of new objects (JAVA:JNEW, JAVA:JMETHOD), the - introspection of values (JAVA:JFIELD), the execution of methods - (JAVA:JCALL, JAVA:JCALL-RAW, JAVA:JSTATIC) -\item The JSS package (JSS) in contrib introduces a convenient macro - syntax (JSS:SHARPSIGN_HASH_DOUBLQUOTE_MACRO) for accessing Java - methods, and additional convenience funtions. + symbols for manipulating the artifacts of expectation on the JVM, + including creation of new objects \ref{JAVA:JNEW}, \ref{JAVA:JMETHOD}), the + introspection of values \ref{JAVA:JFIELD}, the execution of methods + (\ref{JAVA:JCALL}, \ref{JAVA:JCALL-RAW}, \ref{JAVA:JSTATIC}) +\item The JSS package (\ref{JSS}) in contrib introduces a convenient macro + syntax \ref{JSS:SHARPSIGN_DOUBLEQUOTE_MACRO} for accessing Java + methods, and additional convenience functions. \item Java classes and libraries may be dynamically added to the classpath at runtime (JAVA:ADD-TO-CLASSPATH). \end{itemize} @@ -66,12 +184,12 @@ so what is documented here is subject to change. \begin{itemize} -\item All Lisp values are descendents of LispObject.java -\item Lisp symbols are accessible via either directly referening the +\item All Lisp values are descendants of LispObject.java +\item Lisp symbols are accessible via either directly referencing the Symbol.java instance or by dynamically introspecting the corresponding Package.java instance. -\item The Lisp dynamic envrionment may be saved via - LispThread.bindSpecial(BINDING) and restored via +\item The Lisp dynamic environment may be saved via + \code{LispThread.bindSpecial(BINDING)} and restored via LispThread.resetSpecialBindings(mark). \item Functions may be executed by invocation of the Function.execute(args [...]) @@ -79,55 +197,61 @@ \subsubsection{Lisp FFI} -FFI stands for "Foreign Function Interface", which is the way the -contemporary Lisp world refers to methods of "calling out" from Lisp -into "foreign" langauges and envrionments. This document describes -the various ways that one interacts with Lisp world of Abcl from Java, -considering the hosted Lisp as the "Foreign Function" that needs to be -"Interfaced". - +FFI stands for "Foreign Function Interface" which is the phase which +the contemporary Lisp world refers to methods of "calling out" from +Lisp into "foreign" languages and environments. This document +describes the various ways that one interacts with Lisp world of ABCL +from Java, considering the hosted Lisp as the "Foreign Function" that +needs to be "Interfaced". \subsubsubsection{Calling Lisp from Java} Note: As the entire ABCL Lisp system resides in the org.armedbear.lisp package the following code snippets do not show the relevant import -statements in the interest of brevity. +statements in the interest of brevity. An example of the import +statement would be + +\begin[java]{code} + import org.armedbear.lisp.*; +\end{document} + +to potentially import all the JVM symbol from the `org.armedbear.lisp' +namespace. Per JVM, there can only ever be a single Lisp interpreter. This is started by calling the static method `Interpreter.createInstance()`. -\begin{code}{java} -Interpreter interpreter = Interpreter.createInstance(); +\begin[java]{code} + Interpreter interpreter = Interpreter.createInstance(); \end{code} If this method has already been invoked in the lifetime of the current Java process it will return null, so if you are writing Java whose -lifecycle is a bit out of your control (like in a Java servlet), a +life-cycle is a bit out of your control (like in a Java servlet), a safer invocation pattern might be: -\begin{code}{java} -Interpreter interpreter = Interpreter.getInstance(); -if (interpreter == null) { - interpreter = Interpreter.createInstance(); -} +\begin[java]{code} + Interpreter interpreter = Interpreter.getInstance(); + if (interpreter == null) { + interpreter = Interpreter.createInstance(); + } \end{code} -The Lisp `EVAL` primitive may be simply passed strings for evaluation, +The Lisp \code{eval} primitive may be simply passed strings for evaluation, as follows -\begin{code}{java} -String line = "(load \"file.lisp\")"; -LispObject result = interpreter.eval(line); +\begin[java]{code} + String line = "(load \"file.lisp\")"; + LispObject result = interpreter.eval(line); \end{code} - Notice that all possible return values from an arbitrary Lisp computation are collapsed into a single return value. Doing useful further computation on the `LispObject` depends on knowing what the result of the computation might be, usually involves some amount -of instanceof introspection, and forms a whole topic to itself +of \code{instanceof} introspection, and forms a whole topic to itself (c.f. [Introspecting a LispObject](#introspecting)). Using `EVAL` involves the Lisp interpreter. Lisp functions may be @@ -136,7 +260,7 @@ symbol, and then invokes the `execute()` method with the desired parameters. -\begin{code}{java} +\begin[java]{code} interpreter.eval("(defun foo (msg) (format nil \"You told me '~A'~%\" msg))"); Package pkg = Packages.findPackage("CL-USER"); Symbol foo = pkg.findAccessibleSymbol("FOO"); @@ -152,7 +276,7 @@ definition in the ABCL source, we can invoke the symbol directly. To tell if a `LispObject` contains a reference to a symbol. -\begin{code}{java} +\begin[java]{code} boolean nullp(LispObject object) { LispObject result = Primitives.NULL.execute(object); if (result == NIL) { @@ -160,21 +284,21 @@ } return true; } - \end{code} -/subsubsubsection{Introspecting a LispObject} +\paragraph{Introspecting a LispObject} +\label{topic:Introspecting a LispObject} We present various patterns for introspecting an an arbitrary `LispObject` which can represent the result of every Lisp evaluation into semantics that Java can meaniningfully deal with. -/subsubsubsubsection{LispObject as \java{boolean}} +\paragragh{LispObject as \code{boolean}} If the LispObject a generalized boolean values, one can use \java{getBooleanValue()} to convert to Java: -\begin{code}{java} +\begin[java]{code} LispObject object = Symbol.NIL; boolean javaValue = object.getBooleanValue(); \end{code} @@ -182,17 +306,17 @@ Although since in Lisp, any value other than NIL means "true", the use of Java equality it quite a bit easier and more optimal: -\begin{code}{java} +\begin[java]{code}} boolean javaValue = (object != Symbol.NIL); \end{code} -/subsubsubsubsection{LispObject is a list} +\subsubsubsubsection{LispObject is a list} If LispObject is a list, it will have the type `Cons`. One can then use -the `copyToArray[]` to make things a bit more suitable for Java +the \code{copyToArray} to make things a bit more suitable for Java iteration. -\begin{code}{java} +\begin[java]{code} LispObject result = interpreter.eval("'(1 2 4 5)"); if (result instanceof Cons) { LispObject array[] = ((Cons)result.copyToArray()); @@ -203,7 +327,7 @@ A more Lispy way to iterated down a list is to use the `cdr()` access function just as like one would traverse a list in Lisp:; -\begin{code}{java} +\begin[java]{code} LispObject result = interpreter.eval("'(1 2 4 5)"); while (result != Symbol.NIL) { doSomething(result.car()); @@ -227,6 +351,8 @@ \item Incomplete MOP % TODO go through AMOP with symbols, starting by looking for % matching function signature. + % XXX is this really blocking ANSI conformance? Answer: we have + % to start with such a ``census'' to determine what we have. \end{itemize} ABCL aims to be be a fully conforming ANSI Common Lisp @@ -234,12 +360,24 @@ \section{Extensions} -% TODO document the EXTENSIONS package. +The symbols in the EXTENSIONS package consititutes extensions to the +ANSI standard that are potentially useful to the user. They include +functions for manipulating network sockets, running external programs, +registering object finalizers, constructing reference weakly held by +the garbage collector and others. + +\include{extensions} \section{Multithreading} % TODO document the THREADS package. +\include{threads} \section{History} \end{document} + +% TODO +% 1. Create mechanism for swigging DocString and Lisp docs into +% sections. + Added: trunk/abcl/doc/manual/extensions.tex ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/doc/manual/extensions.tex Fri Jun 17 00:01:10 2011 (r13338) @@ -0,0 +1,248 @@ +%CADDR + Function: (not documented) +%CADR + Function: (not documented) +%CAR + Function: (not documented) +%CDR + Function: (not documented) +*AUTOLOAD-VERBOSE* + Variable: (not documented) +*BATCH-MODE* + Variable: (not documented) +*COMMAND-LINE-ARGUMENT-LIST* + Variable: (not documented) +*DEBUG-CONDITION* + Variable: (not documented) +*DEBUG-LEVEL* + Variable: (not documented) +*DISASSEMBLER* + Variable: (not documented) +*ED-FUNCTIONS* + Variable: (not documented) +*ENABLE-INLINE-EXPANSION* + Variable: (not documented) +*INSPECTOR-HOOK* + Variable: (not documented) +*LISP-HOME* + Variable: (not documented) +*LOAD-TRUENAME-FASL* + Variable: (not documented) +*PRINT-STRUCTURE* + Variable: (not documented) +*REQUIRE-STACK-FRAME* + Variable: (not documented) +*SAVED-BACKTRACE* + Variable: (not documented) +*SUPPRESS-COMPILER-WARNINGS* + Variable: (not documented) +*WARN-ON-REDEFINITION* + Variable: (not documented) +ADJOIN-EQL + Function: (not documented) +ARGLIST + Function: (not documented) +ASSQ + Function: (not documented) +ASSQL + Function: (not documented) +AUTOLOAD + Function: (not documented) +AUTOLOAD-MACRO + Function: (not documented) +AUTOLOADP + Function: (not documented) +AVER + Function: (not documented) +CANCEL-FINALIZATION + Function: (not documented) +CHAR-TO-UTF8 + Function: (not documented) +CHARPOS + Function: (not documented) +CLASSP + Function: (not documented) +COLLECT + Function: (not documented) +COMPILE-FILE-IF-NEEDED + Function: (not documented) +COMPILE-SYSTEM + Function: (not documented) +COMPILER-ERROR + Function: (not documented) + Class: (not documented) +COMPILER-UNSUPPORTED-FEATURE-ERROR + Class: (not documented) +DESCRIBE-COMPILER-POLICY + Function: (not documented) +DOUBLE-FLOAT-NEGATIVE-INFINITY + Variable: (not documented) +DOUBLE-FLOAT-POSITIVE-INFINITY + Variable: (not documented) +DUMP-JAVA-STACK + Function: (not documented) +EXIT + Function: (not documented) +FEATUREP + Function: (not documented) +FILE-DIRECTORY-P + Function: (not documented) +FINALIZE + Function: (not documented) +FIXNUMP + Function: (not documented) +GC + Function: (not documented) +GET-FLOATING-POINT-MODES + Function: (not documented) +GET-SOCKET-STREAM + Function: :ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER. +GETENV + Function: Return the value of the environment VARIABLE if it exists, otherwise return NIL. +GROVEL-JAVA-DEFINITIONS + Function: (not documented) +INIT-GUI + Function: (not documented) +INTERNAL-COMPILER-ERROR + Function: (not documented) + Class: (not documented) +INTERRUPT-LISP + Function: (not documented) +JAR-PATHNAME + Class: (not documented) +MACROEXPAND-ALL + Function: (not documented) +MAILBOX + Class: (not documented) +MAKE-DIALOG-PROMPT-STREAM + Function: (not documented) +MAKE-SERVER-SOCKET + Function: (not documented) +MAKE-SLIME-INPUT-STREAM + Function: (not documented) +MAKE-SLIME-OUTPUT-STREAM + Function: (not documented) +MAKE-SOCKET + Function: (not documented) +MAKE-TEMP-FILE + Function: (not documented) +MAKE-WEAK-REFERENCE + Function: (not documented) +MEMQ + Function: (not documented) +MEMQL + Function: (not documented) +MOST-NEGATIVE-JAVA-LONG + Variable: (not documented) +MOST-POSITIVE-JAVA-LONG + Variable: (not documented) +MUTEX + Class: (not documented) +NEQ + Function: (not documented) +NIL-VECTOR + Class: (not documented) +PATHNAME-JAR-P + Function: Predicate for whether PATHNAME references a JAR. +PATHNAME-URL-P + Function: Predicate for whether PATHNAME references a URL. +PRECOMPILE + Function: (not documented) +PROBE-DIRECTORY + Function: (not documented) +PROCESS + Function: (not documented) +PROCESS-ALIVE-P + Function: (not documented) +PROCESS-ERROR + Function: (not documented) +PROCESS-EXIT-CODE + Function: (not documented) +PROCESS-INPUT + Function: (not documented) +PROCESS-KILL + Function: (not documented) +PROCESS-OUTPUT + Function: (not documented) +PROCESS-P + Function: (not documented) +PROCESS-WAIT + Function: (not documented) +QUIT + Function: (not documented) +RESOLVE + Function: (not documented) +RUN-PROGRAM + Function: (not documented) +RUN-SHELL-COMMAND + Function: (not documented) +SERVER-SOCKET-CLOSE + Function: (not documented) +SET-FLOATING-POINT-MODES + Function: (not documented) +SHOW-RESTARTS + Function: (not documented) +SIMPLE-SEARCH + Function: (not documented) +SIMPLE-STRING-FILL + Function: (not documented) +SIMPLE-STRING-SEARCH + Function: (not documented) +SINGLE-FLOAT-NEGATIVE-INFINITY + Variable: (not documented) +SINGLE-FLOAT-POSITIVE-INFINITY + Variable: (not documented) +SLIME-INPUT-STREAM + Class: (not documented) +SLIME-OUTPUT-STREAM + Class: (not documented) +SOCKET-ACCEPT + Function: (not documented) +SOCKET-CLOSE + Function: (not documented) +SOCKET-LOCAL-ADDRESS + Function: Returns the local address of the given socket as a dotted quad string. +SOCKET-LOCAL-PORT + Function: Returns the local port number of the given socket. +SOCKET-PEER-ADDRESS + Function: Returns the peer address of the given socket as a dotted quad string. +SOCKET-PEER-PORT + Function: Returns the peer port number of the given socket. +SOURCE + Function: (not documented) +SOURCE-FILE-POSITION + Function: (not documented) +SOURCE-PATHNAME + Function: (not documented) +SPECIAL-VARIABLE-P + Function: (not documented) +STRING-FIND + Function: (not documented) +STRING-INPUT-STREAM-CURRENT + Function: (not documented) +STRING-POSITION + Function: (not documented) +STYLE-WARN + Function: (not documented) +TRULY-THE + Function: (not documented) +UPTIME + Function: (not documented) +URI-DECODE + Function: (not documented) +URI-ENCODE + Function: (not documented) +URL-PATHNAME + Class: (not documented) +URL-PATHNAME-AUTHORITY + Function: (not documented) +URL-PATHNAME-FRAGMENT + Function: (not documented) +URL-PATHNAME-QUERY + Function: (not documented) +URL-PATHNAME-SCHEME + Function: (not documented) +WEAK-REFERENCE + Class: (not documented) +WEAK-REFERENCE-VALUE + Function: (not documented) Added: trunk/abcl/doc/manual/index.sty ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/doc/manual/index.sty Fri Jun 17 00:01:10 2011 (r13338) @@ -0,0 +1,16 @@ +% preamble for the Manual +% +% The goal is to move all the ``technical'' looking stuff here, +% leaving the manual itself as much as a pure content to be +% comfortably read and modified with a text editor. + +\documentclass[10pt]{article} + +\usepackage{color,hyperref} +\definecolor{darkblue}{rgb}{0.0,0.0,0.3} +\hypersetup{colorlinks,breaklinks, + linkcolor=darkblue,urlcolor=darkblue, + anchorcolor=darkblue,citecolor=darkblue} + +\usepackage{a4wide} + Added: trunk/abcl/doc/manual/java.tex ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/doc/manual/java.tex Fri Jun 17 00:01:10 2011 (r13338) @@ -0,0 +1,50 @@ +THREADS:CURRENT-THREAD + Function: (not documented) +THREADS:DESTROY-THREAD + Function: (not documented) +THREADS:GET-MUTEX + Function: Acquires a lock on the `mutex'. +THREADS:INTERRUPT-THREAD + Function: Interrupts THREAD and forces it to apply FUNCTION to ARGS. +THREADS:MAILBOX-EMPTY-P + Function: Returns non-NIL if the mailbox can be read from, NIL otherwise. +THREADS:MAILBOX-PEEK + Function: Returns two values. The second returns non-NIL when the mailbox +THREADS:MAILBOX-READ + Function: Blocks on the mailbox until an item is available for reading. +THREADS:MAILBOX-SEND + Function: Sends an item into the mailbox, notifying 1 waiter +THREADS:MAKE-MAILBOX + Function: (not documented) +THREADS:MAKE-MUTEX + Function: (not documented) +THREADS:MAKE-THREAD + Function: (not documented) +THREADS:MAKE-THREAD-LOCK + Function: Returns an object to be used with the `with-thread-lock' macro. +THREADS:MAPCAR-THREADS + Function: (not documented) +THREADS:OBJECT-NOTIFY + Function: (not documented) +THREADS:OBJECT-NOTIFY-ALL + Function: (not documented) +THREADS:OBJECT-WAIT + Function: (not documented) +THREADS:RELEASE-MUTEX + Function: Releases a lock on the `mutex'. +THREADS:SYNCHRONIZED-ON + Function: (not documented) +THREADS:THREAD + Class: (not documented) +THREADS:THREAD-ALIVE-P + Function: Boolean predicate whether THREAD is alive. +THREADS:THREAD-JOIN + Function: Waits for thread to finish. +THREADS:THREAD-NAME + Function: (not documented) +THREADS:THREADP + Function: (not documented) +THREADS:WITH-MUTEX + Function: (not documented) +THREADS:WITH-THREAD-LOCK + Function: (not documented) Added: trunk/abcl/doc/manual/threads.tex ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/doc/manual/threads.tex Fri Jun 17 00:01:10 2011 (r13338) @@ -0,0 +1,50 @@ +THREADS:CURRENT-THREAD + Function: (not documented) +THREADS:DESTROY-THREAD + Function: (not documented) +THREADS:GET-MUTEX + Function: Acquires a lock on the `mutex'. +THREADS:INTERRUPT-THREAD + Function: Interrupts THREAD and forces it to apply FUNCTION to ARGS. +THREADS:MAILBOX-EMPTY-P + Function: Returns non-NIL if the mailbox can be read from, NIL otherwise. +THREADS:MAILBOX-PEEK + Function: Returns two values. The second returns non-NIL when the mailbox +THREADS:MAILBOX-READ + Function: Blocks on the mailbox until an item is available for reading. +THREADS:MAILBOX-SEND + Function: Sends an item into the mailbox, notifying 1 waiter +THREADS:MAKE-MAILBOX + Function: (not documented) +THREADS:MAKE-MUTEX + Function: (not documented) +THREADS:MAKE-THREAD + Function: (not documented) +THREADS:MAKE-THREAD-LOCK + Function: Returns an object to be used with the `with-thread-lock' macro. +THREADS:MAPCAR-THREADS + Function: (not documented) +THREADS:OBJECT-NOTIFY + Function: (not documented) +THREADS:OBJECT-NOTIFY-ALL + Function: (not documented) +THREADS:OBJECT-WAIT + Function: (not documented) +THREADS:RELEASE-MUTEX + Function: Releases a lock on the `mutex'. +THREADS:SYNCHRONIZED-ON + Function: (not documented) +THREADS:THREAD + Class: (not documented) +THREADS:THREAD-ALIVE-P + Function: Boolean predicate whether THREAD is alive. +THREADS:THREAD-JOIN + Function: Waits for thread to finish. +THREADS:THREAD-NAME + Function: (not documented) +THREADS:THREADP + Function: (not documented) +THREADS:WITH-MUTEX + Function: (not documented) +THREADS:WITH-THREAD-LOCK + Function: (not documented) From mevenson at common-lisp.net Fri Jun 17 09:03:54 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 02:03:54 -0700 Subject: [armedbear-cvs] r13339 - trunk/abcl Message-ID: Author: mevenson Date: Fri Jun 17 02:03:53 2011 New Revision: 13339 Log: Comments for Ant based build properties template. Modified: trunk/abcl/abcl.properties.in Modified: trunk/abcl/abcl.properties.in ============================================================================== --- trunk/abcl/abcl.properties.in Fri Jun 17 00:01:10 2011 (r13338) +++ trunk/abcl/abcl.properties.in Fri Jun 17 02:03:53 2011 (r13339) @@ -1,13 +1,24 @@ # $Id$ -# abcl.build.incremental attempts to perform incremental compilation +# Template for settings the Ant based build process. + +# Attempt to perform incremental compilation? #abcl.build.incremental=true -# abcl.compile.lisp.skip skips the compilation of Lisp sources in Netbeans (for debugging) +# skips the compilation of Lisp sources in Netbeans (for debugging) #abcl.compile.lisp.skip=true # java.options sets the Java options in the abcl wrapper scripts -#java.options=-Xmx1g + +# Examples + +# set the JVM to use a maximum of 1GB of RAM (only works for 64bit JVMs) +#java.options=-d64 -Xmx1g + +# The unloading of class definitions is a per jvm policy. For those +# implementations which run out of permgen space, the following should +# help things out. +#java.options=-d64 -XX:+CMSClassUnloadingEnabled -XX:MaxPermSize=1g # Additional site specific startup code to be merged in 'system.lisp' #abcl.startup.file=${basedir}/startup.lisp From mevenson at common-lisp.net Fri Jun 17 09:25:53 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 02:25:53 -0700 Subject: [armedbear-cvs] r13340 - in trunk/abcl/contrib/abcl-asdf: . tests Message-ID: Author: mevenson Date: Fri Jun 17 02:25:53 2011 New Revision: 13340 Log: Rough cut of what declaring Maven dependencies in ASDF would be like. Added: trunk/abcl/contrib/abcl-asdf/ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp trunk/abcl/contrib/abcl-asdf/tests/ trunk/abcl/contrib/abcl-asdf/tests/example.lisp trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Added: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Fri Jun 17 02:25:53 2011 (r13340) @@ -0,0 +1,9 @@ +;;;; -*- Mode: LISP -*- +(in-package :asdf) + +(defsystem :abcl-asdf + :author "Mark Evenson" + :version "0.1.0" + :components + ((:module base :pathname "" :components + ((:file "abcl-asdf"))))) \ No newline at end of file Added: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Fri Jun 17 02:25:53 2011 (r13340) @@ -0,0 +1,32 @@ +(defpackage #:abcl-asdf + (:use :cl) + (:export #:package)) + +(in-package :asdf-jar) + +(in-package :asdf) +(defclass iri (static-class) ()) + +(defclass mvn (iri) ()) + +;;; We interpret compilation to ensure that load-op will succeed +(defmethod perform ((operation compile-op) (component mvn)) + (let ((version (component-version mvn))) + (mvn:satisfy (component-name mvn) + :version (if version version :latest)))) + +(defmethod perform ((operation load-op) (component mvn)) + (let ((version (component-version mvn))) + (java:add-to-classpath + (as-classpath (mvn:satisfy (component-name mvn) + :version (if version version :latest)))))) + +(defun decompose (iri) + ;;; XXX test + `((:scheme :jvm) + (:authority :mvn) + (:host "log4j") + (:version "1.4.10"))) + +(defun mvn:satisfy (name &key (version :latest)) + ;;; XXX either invoke mvn in the same jvm or fork a process) Added: trunk/abcl/contrib/abcl-asdf/tests/example.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/abcl-asdf/tests/example.lisp Fri Jun 17 02:25:53 2011 (r13340) @@ -0,0 +1,5 @@ +(require :jss) + +(let ((logger (#"getLogger" 'Logger (symbol-name (gensym))))) + (#"log" logger "Kilroy wuz here.")) + Added: trunk/abcl/contrib/abcl-asdf/tests/log4j.asd ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Fri Jun 17 02:25:53 2011 (r13340) @@ -0,0 +1,10 @@ +;;;; -*- Mode: LISP -*- +(in-package :asdf) + +(defsystem :log4j + :components + ((:mvn "log4j" :version "1.4.9") + (:module src :pathname "") + ((:file "example")))) + + From mevenson at common-lisp.net Fri Jun 17 09:34:07 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 02:34:07 -0700 Subject: [armedbear-cvs] r13341 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Fri Jun 17 02:34:07 2011 New Revision: 13341 Log: Add the correct symbols from the JAVA package. Modified: trunk/abcl/doc/manual/java.tex Modified: trunk/abcl/doc/manual/java.tex ============================================================================== --- trunk/abcl/doc/manual/java.tex Fri Jun 17 02:25:53 2011 (r13340) +++ trunk/abcl/doc/manual/java.tex Fri Jun 17 02:34:07 2011 (r13341) @@ -1,50 +1,148 @@ -THREADS:CURRENT-THREAD - Function: (not documented) -THREADS:DESTROY-THREAD - Function: (not documented) -THREADS:GET-MUTEX - Function: Acquires a lock on the `mutex'. -THREADS:INTERRUPT-THREAD - Function: Interrupts THREAD and forces it to apply FUNCTION to ARGS. -THREADS:MAILBOX-EMPTY-P - Function: Returns non-NIL if the mailbox can be read from, NIL otherwise. -THREADS:MAILBOX-PEEK - Function: Returns two values. The second returns non-NIL when the mailbox -THREADS:MAILBOX-READ - Function: Blocks on the mailbox until an item is available for reading. -THREADS:MAILBOX-SEND - Function: Sends an item into the mailbox, notifying 1 waiter -THREADS:MAKE-MAILBOX - Function: (not documented) -THREADS:MAKE-MUTEX - Function: (not documented) -THREADS:MAKE-THREAD - Function: (not documented) -THREADS:MAKE-THREAD-LOCK - Function: Returns an object to be used with the `with-thread-lock' macro. -THREADS:MAPCAR-THREADS - Function: (not documented) -THREADS:OBJECT-NOTIFY - Function: (not documented) -THREADS:OBJECT-NOTIFY-ALL - Function: (not documented) -THREADS:OBJECT-WAIT - Function: (not documented) -THREADS:RELEASE-MUTEX - Function: Releases a lock on the `mutex'. -THREADS:SYNCHRONIZED-ON - Function: (not documented) -THREADS:THREAD +%JGET-PROPERTY-VALUE + Function: Gets a JavaBeans property on JAVA-OBJECT. +%JSET-PROPERTY-VALUE + Function: Sets a JavaBean property on JAVA-OBJECT. +*JAVA-OBJECT-TO-STRING-LENGTH* + Variable: Length to truncate toString() PRINT-OBJECT output for an otherwise unspecialized JAVA-OBJECT. Can be set to NIL to indicate no limit. +ADD-TO-CLASSPATH + Function: (not documented) +CHAIN + Function: (not documented) +DESCRIBE-JAVA-OBJECT + Function: (not documented) +DUMP-CLASSPATH + Function: (not documented) +ENSURE-JAVA-CLASS + Function: (not documented) +ENSURE-JAVA-OBJECT + Function: Ensures OBJ is wrapped in a JAVA-OBJECT, wrapping it if necessary. +GET-DEFAULT-CLASSLOADER + Function: (not documented) +JARRAY-COMPONENT-TYPE + Function: Returns the component type of the array type ATYPE +JARRAY-LENGTH + Function: (not documented) +JARRAY-REF + Function: Dereferences the Java array JAVA-ARRAY using the given INDICIES, coercing the result into a Lisp object, if possible. +JARRAY-REF-RAW + Function: Dereference the Java array JAVA-ARRAY using the given INDICIES. Does not attempt to coerce the result into a Lisp object. +JARRAY-SET + Function: Stores NEW-VALUE at the given index in JAVA-ARRAY. +JAVA-CLASS Class: (not documented) -THREADS:THREAD-ALIVE-P - Function: Boolean predicate whether THREAD is alive. -THREADS:THREAD-JOIN - Function: Waits for thread to finish. -THREADS:THREAD-NAME - Function: (not documented) -THREADS:THREADP - Function: (not documented) -THREADS:WITH-MUTEX - Function: (not documented) -THREADS:WITH-THREAD-LOCK - Function: (not documented) +JAVA-EXCEPTION + Class: (not documented) +JAVA-EXCEPTION-CAUSE + Function: Returns the cause of JAVA-EXCEPTION. (The cause is the Java Throwable +JAVA-OBJECT + Class: (not documented) +JAVA-OBJECT-P + Function: Returns T if OBJECT is a JAVA-OBJECT. +JCALL + Function: Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS, coercing the result into a Lisp object, if possible. +JCALL-RAW + Function: Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS. Does not attempt to coerce the result into a Lisp object. +JCLASS + Function: 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. +JCLASS-ARRAY-P + Function: Returns T if CLASS is an array class +JCLASS-CONSTRUCTORS + Function: Returns a vector of constructors for CLASS +JCLASS-FIELD + Function: Returns the field named FIELD-NAME of CLASS +JCLASS-FIELDS + Function: Returns a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) fields of CLASS +JCLASS-INTERFACE-P + Function: Returns T if CLASS is an interface +JCLASS-INTERFACES + Function: Returns the vector of interfaces of CLASS +JCLASS-METHODS + Function: Return a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) methods of CLASS +JCLASS-NAME + Function: When called with one argument, returns the name of the Java class +JCLASS-OF + Function: (not documented) +JCLASS-SUPERCLASS + Function: Returns the superclass of CLASS, or NIL if it hasn't got one +JCLASS-SUPERCLASS-P + Function: Returns T if CLASS-1 is a superclass or interface of CLASS-2 +JCOERCE + Function: Attempts to coerce OBJECT into a JavaObject of class INTENDED-CLASS. Raises a TYPE-ERROR if no conversion is possible. +JCONSTRUCTOR + Function: Returns a reference to the Java constructor of CLASS-REF with the given PARAMETER-CLASS-REFS. +JCONSTRUCTOR-PARAMS + Function: Returns a vector of parameter types (Java classes) for CONSTRUCTOR +JEQUAL + Function: Compares obj1 with obj2 using java.lang.Object.equals() +JFIELD + Function: Retrieves or modifies a field in a Java class or instance. +JFIELD-NAME + Function: Returns the name of FIELD as a Lisp string +JFIELD-RAW + Function: Retrieves or modifies a field in a Java class or instance. Does not +JFIELD-TYPE + Function: Returns the type (Java class) of FIELD +JINSTANCE-OF-P + Function: OBJ is an instance of CLASS (or one of its subclasses) +JINTERFACE-IMPLEMENTATION + Function: Creates and returns an implementation of a Java interface with +JMAKE-INVOCATION-HANDLER + Function: (not documented) +JMAKE-PROXY + Function: (not documented) +JMEMBER-PROTECTED-P + Function: MEMBER is a protected member of its declaring class +JMEMBER-PUBLIC-P + Function: MEMBER is a public member of its declaring class +JMEMBER-STATIC-P + Function: MEMBER is a static member of its declaring class +JMETHOD + Function: Returns a reference to the Java method METHOD-NAME of CLASS-REF with the given PARAMETER-CLASS-REFS. +JMETHOD-LET + Function: (not documented) +JMETHOD-NAME + Function: Returns the name of METHOD as a Lisp string +JMETHOD-PARAMS + Function: Returns a vector of parameter types (Java classes) for METHOD +JMETHOD-RETURN-TYPE + Function: Returns the result type (Java class) of the METHOD +JNEW + Function: Invokes the Java constructor CONSTRUCTOR with the arguments ARGS. +JNEW-ARRAY + Function: Creates a new Java array of type ELEMENT-TYPE, with the given DIMENSIONS. +JNEW-ARRAY-FROM-ARRAY + Function: Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref) +JNEW-ARRAY-FROM-LIST + Function: (not documented) +JNEW-RUNTIME-CLASS + Function: (not documented) +JNULL-REF-P + Function: Returns a non-NIL value when the JAVA-OBJECT `object` is `null`, +JOBJECT-CLASS + Function: Returns the Java class that OBJ belongs to +JOBJECT-LISP-VALUE + Function: Attempts to coerce JAVA-OBJECT into a Lisp object. +JPROPERTY-VALUE + Function: (not documented) +JREDEFINE-METHOD + Function: (not documented) +JREGISTER-HANDLER + Function: (not documented) +JRESOLVE-METHOD + Function: Finds the most specific Java method METHOD-NAME on INSTANCE applicable to arguments ARGS. Returns NIL if no suitable method is found. The algorithm used for resolution is the same used by JCALL when it is called with a string as the first parameter (METHOD-REF). +JRUN-EXCEPTION-PROTECTED + Function: Invokes the function CLOSURE and returns the result. Signals an error if stack or heap exhaustion occurs. +JRUNTIME-CLASS-EXISTS-P + Function: (not documented) +JSTATIC + Function: Invokes the static method METHOD on class CLASS with ARGS. +JSTATIC-RAW + Function: Invokes the static method METHOD on class CLASS with ARGS. Does not attempt to coerce the arguments or result into a Lisp object. +MAKE-CLASSLOADER + Function: (not documented) +MAKE-IMMEDIATE-OBJECT + Function: Attempts to coerce a given Lisp object into a java-object of the +REGISTER-JAVA-EXCEPTION + Function: Registers the Java Throwable named by the symbol EXCEPTION-NAME as the condition designated by CONDITION-SYMBOL. Returns T if successful, NIL if not. +UNREGISTER-JAVA-EXCEPTION + Function: Unregisters the Java Throwable EXCEPTION-NAME previously registered by REGISTER-JAVA-EXCEPTION. From mevenson at common-lisp.net Fri Jun 17 10:11:24 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 03:11:24 -0700 Subject: [armedbear-cvs] r13342 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Fri Jun 17 03:11:24 2011 New Revision: 13342 Log: Implementation strategy: use the Maven Ant tasks to drive via build.xml. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Fri Jun 17 02:34:07 2011 (r13341) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Fri Jun 17 03:11:24 2011 (r13342) @@ -2,6 +2,10 @@ (:use :cl) (:export #:package)) +(defpackage #:mvn + (:use :cl) + (:export #:satisfy)) + (in-package :asdf-jar) (in-package :asdf) @@ -9,6 +13,7 @@ (defclass mvn (iri) ()) + ;;; We interpret compilation to ensure that load-op will succeed (defmethod perform ((operation compile-op) (component mvn)) (let ((version (component-version mvn))) @@ -29,4 +34,46 @@ (:version "1.4.10"))) (defun mvn:satisfy (name &key (version :latest)) - ;;; XXX either invoke mvn in the same jvm or fork a process) + (let ((build.xml (make-temp-file))) + (with-open-file (s build.xml :direction :output) + (write-string *ant-build-template* s )) + (run-program + (format nil "ant -find ~A" build.xml)))) + +#| + +Ant with Maven tasks would add the following + + + + +|# + +(defvar *ant-build-template* + (format nil + " + + + + + + + + + + + + + + + + + +" (symbol-name (gensym)) "junit" "junit" "3.8.2")) + + + + + + From mevenson at common-lisp.net Fri Jun 17 11:25:14 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 04:25:14 -0700 Subject: [armedbear-cvs] r13343 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Fri Jun 17 04:25:14 2011 New Revision: 13343 Log: Fix compilation of ABCL-ASDF contrib. It still doesn't run. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Fri Jun 17 03:11:24 2011 (r13342) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Fri Jun 17 04:25:14 2011 (r13343) @@ -6,14 +6,13 @@ (:use :cl) (:export #:satisfy)) -(in-package :asdf-jar) +(in-package :abcl-asdf) (in-package :asdf) (defclass iri (static-class) ()) (defclass mvn (iri) ()) - ;;; We interpret compilation to ensure that load-op will succeed (defmethod perform ((operation compile-op) (component mvn)) (let ((version (component-version mvn))) From mevenson at common-lisp.net Fri Jun 17 11:57:34 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 04:57:34 -0700 Subject: [armedbear-cvs] r13344 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Fri Jun 17 04:57:33 2011 New Revision: 13344 Log: Undebugged implementation of enumerating the source and fasls. Using the SYSTEM:ZIP with a hashtable of source to fasl mappings eliminates the need for any intermediate directory. Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Fri Jun 17 04:25:14 2011 (r13343) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Fri Jun 17 04:57:33 2011 (r13344) @@ -1,10 +1,9 @@ -(defpackage :asdf-jar +(defpackage #:asdf-jar (:use :cl) (:export #:package)) (in-package :asdf-jar) - (defvar *systems*) (defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system)) (push c *systems*)) @@ -27,21 +26,39 @@ (when verbose (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar)) (setf *systems* nil) + (when verbose + (format verbose "~&Forcing recursive compilation of ~A." package-jar)) (asdf:compile-system system :force t) - (let* ((dir (asdf:component-pathname system)) - (wild-contents (merge-pathnames "**/*" dir)) - (contents (directory wild-contents)) - (topdir (truename (merge-pathnames "../" dir)))) - (when verbose - (format verbose "~&Packaging contents in ~A." package-jar)) - (dolist (system (append (list system) *systems*)) - (let ((base (slot-value system 'asdf:absolute-pathname)) - (name (slot-value system 'asdf:name)) - (asdf (slot-value system source-file))) - (setf (gethash asdf mapping) (relative-path base name asdf)))) + (when verbose + (format verbose "~&Packaging contents in ~A." package-jar)) + (dolist (system (append (list system) *systems*)) + (let ((base (slot-value system 'asdf::absolute-pathname)) + (name (slot-value system 'asdf::name)) + (asdf (slot-value system 'asdf::source-file))) + (setf (gethash asdf mapping) (relative-path base name asdf)) + ;;; XXX iterate through the rest of the contents of the ;;; system, adding appropiate entries - (system:zip package-jar mapping)))) + (let ((sources + (mapwalk (lambda (c) (typep c 'asdf::source-file)) + (lambda (c) (input-files c ))))) + (loop :for source :in sources + :do (setf (gethash (pathname-namestring source) mapping) + (make-pathname :defaults source + :type "abcl")))))) + (system:zip package-jar mapping))) + +;;; This more Map than Walk at this point ... +(defun mapwalk (system test-if callable) + (declare (type system asdf:system)) + (let ((components + (loop + :for component :being :each :hash-value + :of (slot-value system 'asdf::components-by-name) + :when (funcall test-if component) + :collect component))) + (loop :for component :in components + :collecting (apply callable component)))) (defun relative-path (base dir file) (let* ((relative From mevenson at common-lisp.net Fri Jun 17 13:10:15 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 06:10:15 -0700 Subject: [armedbear-cvs] r13345 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Fri Jun 17 06:10:13 2011 New Revision: 13345 Log: Fix all compilation warnings. Still not expected that ABCL-ASDF works, esp. in the use of RUN-PROGRAM. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Fri Jun 17 04:57:33 2011 (r13344) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Fri Jun 17 06:10:13 2011 (r13345) @@ -2,11 +2,11 @@ (:use :cl) (:export #:package)) + (defpackage #:mvn (:use :cl) - (:export #:satisfy)) - -(in-package :abcl-asdf) + (:export #:satisfy + #:as-classpath)) (in-package :asdf) (defclass iri (static-class) ()) @@ -14,30 +14,32 @@ (defclass mvn (iri) ()) ;;; We interpret compilation to ensure that load-op will succeed -(defmethod perform ((operation compile-op) (component mvn)) - (let ((version (component-version mvn))) - (mvn:satisfy (component-name mvn) +(defmethod perform ((op compile-op) (c mvn)) + (let ((version (component-version c))) + (mvn:satisfy (component-name c) :version (if version version :latest)))) -(defmethod perform ((operation load-op) (component mvn)) - (let ((version (component-version mvn))) +(defmethod perform ((operation load-op) (c mvn)) + (let ((version (component-version c))) (java:add-to-classpath - (as-classpath (mvn:satisfy (component-name mvn) - :version (if version version :latest)))))) + (mvn:as-classpath + (mvn:satisfy (component-name c) + :version (if version version :latest)))))) + +(in-package :abcl-asdf) (defun decompose (iri) + (declare (ignore iri)) ;;; XXX test `((:scheme :jvm) (:authority :mvn) (:host "log4j") (:version "1.4.10"))) -(defun mvn:satisfy (name &key (version :latest)) - (let ((build.xml (make-temp-file))) - (with-open-file (s build.xml :direction :output) - (write-string *ant-build-template* s )) - (run-program - (format nil "ant -find ~A" build.xml)))) +(in-package :mvn) + +(defparameter *maven-ant-tasks.jar* + "/export/home/evenson/src/apache-maven-3.0.3/maven-ant-tasks-2.1.1.jar") #| @@ -52,6 +54,7 @@ (format nil " @@ -71,8 +74,22 @@ " (symbol-name (gensym)) "junit" "junit" "3.8.2")) +(defun satisfy (name &key (version :latest)) + (declare (ignore name version)) + (let ((build.xml (ext:make-temp-file))) + (with-open-file (s build.xml :direction :output) + (write-string *ant-build-template* s )) + (ext:run-program + (format nil "ant -find ~A -lib ~A" + build.xml + *maven-ant-tasks.jar*)))) + +(defun as-classpath (mvn) + "For a given MVN entry, return a list of loadable archives + suitable for addition to the classpath." + (declare (ignore mvn)) + (error "unimplemented")) + - - From mevenson at common-lisp.net Fri Jun 17 13:10:22 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 06:10:22 -0700 Subject: [armedbear-cvs] r13346 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Fri Jun 17 06:10:21 2011 New Revision: 13346 Log: Incremental progress towards getting ASDF-JAR working. Now we just need to come up with the logic for specifying the entry within the jar for the source and the fasls. Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Fri Jun 17 06:10:13 2011 (r13345) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Fri Jun 17 06:10:21 2011 (r13346) @@ -21,7 +21,7 @@ (package-jar-name (format nil "~A~A-~A.jar" name (when recursive "-all") version)) (package-jar - (make-pathname :directory out :defaults package-jar-name)) + (make-pathname :directory (pathname-directory out) :defaults package-jar-name)) (mapping (make-hash-table :test 'equal))) (when verbose (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar)) @@ -40,25 +40,35 @@ ;;; XXX iterate through the rest of the contents of the ;;; system, adding appropiate entries (let ((sources - (mapwalk (lambda (c) (typep c 'asdf::source-file)) - (lambda (c) (input-files c ))))) + (mapwalk system + (lambda (c) (typep c 'asdf::source-file)) + (lambda (c) (slot-value c 'asdf::absolute-pathname))))) (loop :for source :in sources - :do (setf (gethash (pathname-namestring source) mapping) - (make-pathname :defaults source - :type "abcl")))))) - (system:zip package-jar mapping))) + :for source-entry = (relative-pathname base source) + :for output = (make-pathname + :defaults (asdf:apply-output-translations source) + :type "abcl") + :for output-entry = (relative-pathname base output) + :do (setf (gethash (namestring source) mapping) + source-entry) + :do (setf (gethash (namestring output) mapping) + output-entry))))) + (system:zip package-jar mapping))) + +(defun relative-pathname (base source) + (declare (ignore base source)) + (error "unimplemented.")) ;;; This more Map than Walk at this point ... (defun mapwalk (system test-if callable) (declare (type system asdf:system)) - (let ((components - (loop - :for component :being :each :hash-value - :of (slot-value system 'asdf::components-by-name) - :when (funcall test-if component) - :collect component))) - (loop :for component :in components - :collecting (apply callable component)))) + (loop + :for component :being :each :hash-value + :of (slot-value system 'asdf::components-by-name) + :when + (funcall test-if component) + :collect + (funcall callable component))) (defun relative-path (base dir file) (let* ((relative From mevenson at common-lisp.net Sat Jun 18 06:39:59 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 17 Jun 2011 23:39:59 -0700 Subject: [armedbear-cvs] r13347 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Fri Jun 17 23:39:58 2011 New Revision: 13347 Log: ASDF-JAR:PACKAGE will compile and package asdf systems into jar files. In order to load the fasls from these files, one has to disable ASDF's output translations so that it searches the jar archive. The packaing of recursive dependencies currently doesn't work. Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Fri Jun 17 06:10:21 2011 (r13346) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Fri Jun 17 23:39:58 2011 (r13347) @@ -10,8 +10,12 @@ (defun package (system-name &key (out #p"/var/tmp/") - (recursive t) + (recursive t) ; whether to package dependencies + (force t) ; whether to force ASDF compilation (verbose t)) +"Compile and package the asdf SYSTEM-NAME in a jar. + +Place the resulting packaging in the OUT directory." (let* ((system (asdf:find-system system-name)) (name @@ -19,16 +23,16 @@ (version (slot-value system 'asdf:version)) (package-jar-name - (format nil "~A~A-~A.jar" name (when recursive "-all") version)) + (format nil "~A~A-~A.jar" name (if recursive "-all" "") version)) (package-jar (make-pathname :directory (pathname-directory out) :defaults package-jar-name)) (mapping (make-hash-table :test 'equal))) (when verbose - (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar)) + (format verbose "~&Packaging ASDF definition of ~A~& as ~A." system package-jar)) (setf *systems* nil) (when verbose (format verbose "~&Forcing recursive compilation of ~A." package-jar)) - (asdf:compile-system system :force t) + (asdf:compile-system system :force force) (when verbose (format verbose "~&Packaging contents in ~A." package-jar)) (dolist (system (append (list system) *systems*)) @@ -36,31 +40,29 @@ (name (slot-value system 'asdf::name)) (asdf (slot-value system 'asdf::source-file))) (setf (gethash asdf mapping) (relative-path base name asdf)) - - ;;; XXX iterate through the rest of the contents of the - ;;; system, adding appropiate entries (let ((sources (mapwalk system (lambda (c) (typep c 'asdf::source-file)) (lambda (c) (slot-value c 'asdf::absolute-pathname))))) (loop :for source :in sources - :for source-entry = (relative-pathname base source) + :for source-entry = (relative-path base name source) :for output = (make-pathname :defaults (asdf:apply-output-translations source) :type "abcl") - :for output-entry = (relative-pathname base output) + :for output-entry = (make-pathname + :defaults source-entry + :type "abcl") :do (setf (gethash (namestring source) mapping) source-entry) :do (setf (gethash (namestring output) mapping) output-entry))))) (system:zip package-jar mapping))) -(defun relative-pathname (base source) - (declare (ignore base source)) - (error "unimplemented.")) - ;;; This more Map than Walk at this point ... (defun mapwalk (system test-if callable) + "Apply CALLABLE to all components of asdf SYSTEM which satisfy TEST-IF. + +Both CALLABLE and TEST-IF are functions taking an asdf:component as their argument." (declare (type system asdf:system)) (loop :for component :being :each :hash-value @@ -88,6 +90,7 @@ + From mevenson at common-lisp.net Sat Jun 18 14:26:18 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 18 Jun 2011 07:26:18 -0700 Subject: [armedbear-cvs] r13348 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Sat Jun 18 07:26:16 2011 New Revision: 13348 Log: ASDF-JAR:PACKAGE now handles recursive dependencies. Rewrote the dependency walking logic to actually work and to only include output files for component types that have them. Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.asd trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.asd ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.asd Fri Jun 17 23:39:58 2011 (r13347) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.asd Sat Jun 18 07:26:16 2011 (r13348) @@ -1,9 +1,9 @@ ;;;; -*- Mode: LISP -*- -(in-package :Asdf) +(in-package :asdf) (defsystem :asdf-jar :author "Mark Evenson" - :version "0.1.0" + :version "0.2.0" :components ((:module base :pathname "" :components ((:file "asdf-jar"))))) \ No newline at end of file Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Fri Jun 17 23:39:58 2011 (r13347) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Sat Jun 18 07:26:16 2011 (r13348) @@ -4,73 +4,91 @@ (in-package :asdf-jar) -(defvar *systems*) -(defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system)) - (push c *systems*)) +(defvar *debug* nil) (defun package (system-name &key (out #p"/var/tmp/") (recursive t) ; whether to package dependencies - (force t) ; whether to force ASDF compilation + (force nil) ; whether to force ASDF compilation (verbose t)) "Compile and package the asdf SYSTEM-NAME in a jar. -Place the resulting packaging in the OUT directory." +When RECURSIVE is true (the default), recursively add all asdf +dependencies into the same jar. + +Place the resulting packaging in the OUT directory. + +Returns the pathname of the created jar archive. +" (let* ((system (asdf:find-system system-name)) (name (slot-value system 'asdf::name)) (version - (slot-value system 'asdf:version)) + (handler-case (slot-value system 'asdf:version) + (unbound-slot () "unknown"))) + (package-jar-name (format nil "~A~A-~A.jar" name (if recursive "-all" "") version)) (package-jar (make-pathname :directory (pathname-directory out) :defaults package-jar-name)) - (mapping (make-hash-table :test 'equal))) + (mapping (make-hash-table :test 'equal)) + (dependencies (dependent-systems system))) (when verbose (format verbose "~&Packaging ASDF definition of ~A~& as ~A." system package-jar)) - (setf *systems* nil) - (when verbose + (when (and verbose force) (format verbose "~&Forcing recursive compilation of ~A." package-jar)) (asdf:compile-system system :force force) (when verbose - (format verbose "~&Packaging contents in ~A." package-jar)) - (dolist (system (append (list system) *systems*)) + (format verbose "~&Packaging contents in ~A" package-jar)) + (when (and verbose recursive) + (format verbose "~& with recursive dependencies~{ ~A~^, ~}." dependencies)) + (dolist (system (append (list system) + (when recursive + (mapcar #'asdf:find-system dependencies)))) (let ((base (slot-value system 'asdf::absolute-pathname)) (name (slot-value system 'asdf::name)) (asdf (slot-value system 'asdf::source-file))) (setf (gethash asdf mapping) (relative-path base name asdf)) - (let ((sources - (mapwalk system - (lambda (c) (typep c 'asdf::source-file)) - (lambda (c) (slot-value c 'asdf::absolute-pathname))))) - (loop :for source :in sources - :for source-entry = (relative-path base name source) - :for output = (make-pathname - :defaults (asdf:apply-output-translations source) - :type "abcl") - :for output-entry = (make-pathname - :defaults source-entry - :type "abcl") - :do (setf (gethash (namestring source) mapping) - source-entry) - :do (setf (gethash (namestring output) mapping) + (loop :for component :in (all-files system) + :for source = (slot-value component 'asdf::absolute-pathname) + :for source-entry = (relative-path base name source) + :do (setf (gethash source mapping) + source-entry) + :do (when *debug* + (format verbose "~&~A~& => ~A" source source-entry)) + :when (and (typep component 'asdf::source-file) + (not (typep component 'asdf::static-file))) + :do (let ((output + (make-pathname + :defaults (asdf:apply-output-translations source) + :type "abcl")) + (output-entry + (make-pathname :defaults source-entry + :type "abcl"))) + (when *debug* + (format verbose "~&~A~& => ~A" output output-entry)) + (setf (gethash output mapping) output-entry))))) - (system:zip package-jar mapping))) + (system:zip package-jar mapping))) -;;; This more Map than Walk at this point ... -(defun mapwalk (system test-if callable) - "Apply CALLABLE to all components of asdf SYSTEM which satisfy TEST-IF. - -Both CALLABLE and TEST-IF are functions taking an asdf:component as their argument." - (declare (type system asdf:system)) - (loop - :for component :being :each :hash-value - :of (slot-value system 'asdf::components-by-name) - :when - (funcall test-if component) - :collect - (funcall callable component))) +(defun all-files (component) + (loop :for c + :being :each :hash-value :of (slot-value component 'asdf::components-by-name) + :when (typep c 'asdf:module) + :append (all-files c) + :when (typep c 'asdf:source-file) + :append (list c))) + +(defun dependent-systems (system) + (when (not (typep system 'asdf:system)) + (setf system (asdf:find-system system))) + (let* ((dependencies (asdf::component-load-dependencies system)) + (sub-depends + (loop :for dependency :in dependencies + :for sub = (dependent-systems dependency) + :when sub :append sub))) + (remove-duplicates `(, at dependencies , at sub-depends)))) (defun relative-path (base dir file) (let* ((relative From mevenson at common-lisp.net Mon Jun 20 12:01:18 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 20 Jun 2011 05:01:18 -0700 Subject: [armedbear-cvs] r13349 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Jun 20 05:01:18 2011 New Revision: 13349 Log: Implement DIRECTORY wildcard matching for zip inside zip. With this commit, one can load ABCL fasls ("*.abcl") included inside jars successfully. I thought this has been working previously, but am unable to quickly find the evidence. 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 Sat Jun 18 07:26:16 2011 (r13348) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Mon Jun 20 05:01:18 2011 (r13349) @@ -1625,29 +1625,61 @@ LispObject result = NIL; String wild = "/" + pathname.asEntryPath(); - - if (pathname.device.cdr() instanceof Cons) { - return error(new FileError("Unimplemented directory listing of JAR within JAR.", pathname)); - } - final SimpleString wildcard = new SimpleString(wild); - ZipFile jar = ZipCache.get((Pathname)pathname.device.car()); - - for (Enumeration entries = jar.entries(); entries.hasMoreElements();) { - ZipEntry entry = entries.nextElement(); - String entryName = "/" + entry.getName(); - - LispObject matches = Symbol.PATHNAME_MATCH_P - .execute(new SimpleString(entryName), wildcard); + if (pathname.device.cdr() instanceof Cons) { + ZipFile outerJar = ZipCache.get((Pathname)pathname.device.car()); + String entryPath = ((Pathname)pathname.device.cdr().car()).getNamestring(); //??? + if (entryPath.startsWith("/")) { + entryPath = entryPath.substring(1); + } + ZipEntry entry = outerJar.getEntry(entryPath); + InputStream inputStream = null; + try { + inputStream = outerJar.getInputStream(entry); + } catch (IOException e) { + return new FileError("Failed to read zip input stream inside zip.", + pathname); + } + ZipInputStream zipInputStream + = new ZipInputStream(inputStream); - if (!matches.equals(NIL)) { - String namestring = new String(pathname.getNamestring()); - namestring = namestring.substring(0, namestring.lastIndexOf("!/") + 2) - + entry.getName(); - Pathname p = new Pathname(namestring); - result = new Cons(p, result); + try { + while ((entry = zipInputStream.getNextEntry()) != null) { + String entryName = "/" + entry.getName(); + LispObject matches = Symbol.PATHNAME_MATCH_P + .execute(new SimpleString(entryName), wildcard); + + if (!matches.equals(NIL)) { + String namestring = new String(pathname.getNamestring()); + namestring = namestring.substring(0, namestring.lastIndexOf("!/") + 2) + + entry.getName(); + Pathname p = new Pathname(namestring); + result = new Cons(p, result); + } + } + } catch (IOException e) { + return new FileError("Failed to seek through zip inputstream inside zip.", + pathname); } + } else { + ZipFile jar = ZipCache.get((Pathname)pathname.device.car()); + for (Enumeration entries = jar.entries(); + entries.hasMoreElements();) + { + ZipEntry entry = entries.nextElement(); + String entryName = "/" + entry.getName(); + LispObject matches = Symbol.PATHNAME_MATCH_P + .execute(new SimpleString(entryName), wildcard); + + if (!matches.equals(NIL)) { + String namestring = new String(pathname.getNamestring()); + namestring = namestring.substring(0, namestring.lastIndexOf("!/") + 2) + + entry.getName(); + Pathname p = new Pathname(namestring); + result = new Cons(p, result); + } + } } return result; } From mevenson at common-lisp.net Mon Jun 20 14:37:12 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 20 Jun 2011 07:37:12 -0700 Subject: [armedbear-cvs] r13350 - in trunk/abcl: . contrib/asdf-jar Message-ID: Author: mevenson Date: Mon Jun 20 07:37:10 2011 New Revision: 13350 Log: Document the use of the ASDF-JAR contrib. ASDF:ADD-TO-ASDF provides a mechanism to add the contents of a pathname specifying an jar package to be subequently loaded by ASDF. Generalize mechanism to specifiy contrib contents while including "README.markdown" files. Added: trunk/abcl/contrib/asdf-jar/README.markdown Modified: trunk/abcl/build.xml trunk/abcl/contrib/asdf-jar/asdf-jar.asd trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Mon Jun 20 05:01:18 2011 (r13349) +++ trunk/abcl/build.xml Mon Jun 20 07:37:10 2011 (r13350) @@ -469,13 +469,18 @@ + + + + + + - - + @@ -484,10 +489,7 @@ - - - - + Packaged contribs in ${abcl-contrib.jar}. To use contribs, ensure that Added: trunk/abcl/contrib/asdf-jar/README.markdown ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/asdf-jar/README.markdown Mon Jun 20 07:37:10 2011 (r13350) @@ -0,0 +1,59 @@ +ASDF-JAR +======== + + Mark Evenson + Created: 20-JUN-2011 + Modified: 20-JUN-2011 + +ASDF-JAR provides a system for packaging ASDF systems into jar +archives for ABCL. Given a running ABCL image with loadable ASDF +systems the code in this package will recursively package all the +required source and fasls in a jar archive . + +To install ASDF systems, [Quicklisp]() is probably the best +contemporary solution, although a version of ASDF-INSTALL is also +packaged in ABCL contribs. + +[Quicklisp]: http://www.quicklisp.org + +Once the requisite ASDF systems have been installed, ensure that this +contrib is loaded via + + CL-USER) (require :abcl-contrib) + CL-USER> (require :asdf-jar) + +Then, to say package the Perl regular expression system ("CL-PPCRE"), +one uses the ASDF-JAR:PACKAGE as follows: + + CL-USER> (asdf-jar:package :cl-ppcre) + ; Loading #P"/home/evenson/quicklisp/dists/quicklisp/software/cl-ppcre-2.0.3/cl-ppcre.asd" ... + ; Loaded #P"/home/evenson/quicklisp/dists/quicklisp/software/cl-ppcre-2.0.3/cl-ppcre.asd" (0.029 seconds) + Packaging ASDF definition of # + as /var/tmp/cl-ppcre-all-2.0.3.jar. + Packaging contents in /var/tmp/cl-ppcre-all-2.0.3.jar + with recursive dependencies. + #P"/var/tmp/cl-ppcre-all-2.0.3.jar" + +The resulting jar contains all source and fasls required to run the +ASDF system including any transitive ASDF dependencies. Each asdf +system is packaged under its own top level directory within the jar +archive. The jar archive itself is numbered with the version of the +system that was specified in the packaging. + +To load the system from the jar one needs to add the ASDF file +locations to the ASDF *CENTRAL-REGISTRY*. If one wishes to load the +fasls from the jar alone, one needs to tell ASDF not to override its +output translation rules. The function ASDF-JAR:ADD-TO-JAR does both +of these options serving as the basis for customized load strategies +tailored to end-user deployment needs. So, after + + CL-USER> (asdf-jar:add-to-asdf "/var/tmp/cl-ppcre-all-2.0.3.jar") + +a subsequent + + CL-USER> (asdf:load-system :cl-ppcre) + +should load the ASDF system from the jar. + +Setting CL:*LOAD-VERBOSE* will allow one to verify that the subsequent +load is indeed coming from the jar. Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.asd ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.asd Mon Jun 20 05:01:18 2011 (r13349) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.asd Mon Jun 20 07:37:10 2011 (r13350) @@ -6,4 +6,5 @@ :version "0.2.0" :components ((:module base :pathname "" :components - ((:file "asdf-jar"))))) \ No newline at end of file + ((:file "asdf-jar") + (:static-file "README.markdown)))) \ No newline at end of file Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Mon Jun 20 05:01:18 2011 (r13349) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Mon Jun 20 07:37:10 2011 (r13350) @@ -1,6 +1,11 @@ +;;; This file is part of ABCL contrib +;;; +;;; Copyright 2011 Mark + (defpackage #:asdf-jar (:use :cl) - (:export #:package)) + (:export #:package + #:add-to-asdf)) (in-package :asdf-jar) @@ -9,16 +14,18 @@ (defun package (system-name &key (out #p"/var/tmp/") (recursive t) ; whether to package dependencies - (force nil) ; whether to force ASDF compilation + (force nil) ; whether to force ASDF compilation (verbose t)) "Compile and package the asdf SYSTEM-NAME in a jar. When RECURSIVE is true (the default), recursively add all asdf dependencies into the same jar. -Place the resulting packaging in the OUT directory. +Place the resulting packaged jar in the OUT directory. + +If FORCE is true, force asdf to recompile all the necessary fasls. -Returns the pathname of the created jar archive. +Returns the pathname of the packaged jar archive. " (let* ((system (asdf:find-system system-name)) @@ -106,6 +113,30 @@ :directory (nconc (pathname-directory temp-path) (list name))))) +(defun add-to-asdf (jar &key (use-jar-fasls t)) + "Make a given JAR output by the package mechanism loadable by asdf. + +The parameter passed to :USE-JAR-FASLS determines whether to instruct +asdf to use the fasls packaged in the jar. If this is nil, the fasls +will be compiled with respect to the ususual asdf output translation +conventions." + (when (not (typep jar 'pathname)) + (setf jar (pathname jar))) + (when (null (pathname-device jar)) + (setf jar (make-pathname :device (list jar)))) + + ;;; Inform ASDF of all the system definitions in the jar + (loop :for asd + :in (directory (merge-pathnames "*/*.asd" jar)) + :do (pushnew (make-pathname :defaults asd + :name nil :type nil) + asdf:*central-registry*)) + + ;;; Load the FASLs directly from the jar + (when use-jar-fasls + (asdf:initialize-output-translations + `(:output-translations (,(merge-pathnames "/**/*.*" jar)) + :inherit-configuration)))) From mevenson at common-lisp.net Tue Jun 21 08:23:11 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 21 Jun 2011 01:23:11 -0700 Subject: [armedbear-cvs] r13351 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Tue Jun 21 01:23:10 2011 New Revision: 13351 Log: asdf-jar-0.2.1 corrects load-time errors. Deleted: trunk/abcl/contrib/asdf-jar/test.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.asd trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.asd ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.asd Mon Jun 20 07:37:10 2011 (r13350) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.asd Tue Jun 21 01:23:10 2011 (r13351) @@ -3,8 +3,8 @@ (defsystem :asdf-jar :author "Mark Evenson" - :version "0.2.0" + :version "0.2.1" :components ((:module base :pathname "" :components ((:file "asdf-jar") - (:static-file "README.markdown)))) \ No newline at end of file + (:static-file "README.markdown"))))) Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Mon Jun 20 07:37:10 2011 (r13350) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Tue Jun 21 01:23:10 2011 (r13351) @@ -11,12 +11,12 @@ (defvar *debug* nil) -(defun package (system-name - &key (out #p"/var/tmp/") - (recursive t) ; whether to package dependencies - (force nil) ; whether to force ASDF compilation - (verbose t)) -"Compile and package the asdf SYSTEM-NAME in a jar. +(defun package (system + &key (out #p"/var/tmp/") + (recursive t) ; whether to package dependencies + (force nil) ; whether to force ASDF compilation + (verbose t)) +"Compile and package the asdf SYSTEM in a jar. When RECURSIVE is true (the default), recursively add all asdf dependencies into the same jar. @@ -27,14 +27,13 @@ Returns the pathname of the packaged jar archive. " - (let* ((system - (asdf:find-system system-name)) - (name + (when (not (typep system 'asdf:system)) + (setf system (asdf:find-system system))) + (let* ((name (slot-value system 'asdf::name)) (version (handler-case (slot-value system 'asdf:version) (unbound-slot () "unknown"))) - (package-jar-name (format nil "~A~A-~A.jar" name (if recursive "-all" "") version)) (package-jar @@ -42,13 +41,13 @@ (mapping (make-hash-table :test 'equal)) (dependencies (dependent-systems system))) (when verbose - (format verbose "~&Packaging ASDF definition of ~A~& as ~A." system package-jar)) + (format verbose "~&Packaging ASDF definition of ~A" system)) (when (and verbose force) (format verbose "~&Forcing recursive compilation of ~A." package-jar)) (asdf:compile-system system :force force) (when verbose (format verbose "~&Packaging contents in ~A" package-jar)) - (when (and verbose recursive) + (when (and verbose recursive dependencies) (format verbose "~& with recursive dependencies~{ ~A~^, ~}." dependencies)) (dolist (system (append (list system) (when recursive From mevenson at common-lisp.net Tue Jun 21 08:30:25 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 21 Jun 2011 01:30:25 -0700 Subject: [armedbear-cvs] r13352 - trunk/abcl Message-ID: Author: mevenson Date: Tue Jun 21 01:30:25 2011 New Revision: 13352 Log: Ensure we set the version for the release build. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Tue Jun 21 01:23:10 2011 (r13351) +++ trunk/abcl/build.xml Tue Jun 21 01:30:25 2011 (r13352) @@ -355,7 +355,10 @@ + depends="abcl.stamp.version.uptodate,abcl.stamp.version.generate"> + + - Author: mevenson Date: Tue Jun 21 03:11:10 2011 New Revision: 13353 Log: Fix problems with whitespace in JAR-PATHNAME. For dealing with URI Encoding (also known as [Percent Encoding]() we implement the following rules which were implicitly. [Percent Encoding]: http://en.wikipedia.org/wiki/Percent-encoding 1. All pathname components are represented "as is" without escaping. 2. Namestrings are suitably escaped if the Pathname is a URL-PATHNAME or a JAR-PATHNAME. 3. Namestrings should all "round-trip": (when (typep p 'pathname) (equal (namestring p) (namestring (pathname p)))) Users may use EXT:URI-ENCODE and EXT:URI-DECODE to access the escaping rules in circumstances where they wish to manipulate PATHNAME namestrings more directly. All tests in JAR-PATHNAMES now pass. Constructors for PATHNAME now produce ERROR rather than FILE-ERROR as CLHS says "The type file-error consists of error conditions that occur during an attempt to open or close a file, or during some low-level transactions with a file system," which doesn't apply here. Modified: trunk/abcl/doc/design/pathnames/jar-pathnames.markdown trunk/abcl/doc/design/pathnames/url-pathnames.markdown trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/doc/design/pathnames/jar-pathnames.markdown ============================================================================== --- trunk/abcl/doc/design/pathnames/jar-pathnames.markdown Tue Jun 21 01:30:25 2011 (r13352) +++ trunk/abcl/doc/design/pathnames/jar-pathnames.markdown Tue Jun 21 03:11:10 2011 (r13353) @@ -3,7 +3,7 @@ Mark Evenson Created: 09 JAN 2010 - Modified: 26 NOV 2010 + Modified: 21 JUN 2011 Notes towards an implementation of "jar:" references to be contained in Common Lisp `PATHNAME`s within ABCL. @@ -271,6 +271,14 @@ } +URI Encoding +------------ + +As a subtype of URL-PATHNAMES, JAR-PATHNAMES follow all the rules for +that type. Most notably this means that all #\Space characters should +be encoded as '%20' when dealing with jar entries. + + History ------- Modified: trunk/abcl/doc/design/pathnames/url-pathnames.markdown ============================================================================== --- trunk/abcl/doc/design/pathnames/url-pathnames.markdown Tue Jun 21 01:30:25 2011 (r13352) +++ trunk/abcl/doc/design/pathnames/url-pathnames.markdown Tue Jun 21 03:11:10 2011 (r13353) @@ -3,7 +3,7 @@ Mark Evenson Created: 25 MAR 2010 - Modified: 26 NOV 2010 + Modified: 21 JUN 2011 Notes towards an implementation of URL references to be contained in Common Lisp `PATHNAME` objects within ABCL. @@ -119,14 +119,39 @@ A URL Pathname has type URL-PATHNAME, derived from PATHNAME. + +URI Encoding +------------ + +For dealing with URI Encoding (also known as [Percent Encoding]() we +adopt the following rules + +[Percent Encoding]: http://en.wikipedia.org/wiki/Percent-encoding + +1. All pathname components are represented "as is" without escaping. + +2. Namestrings are suitably escaped if the Pathname is a URL-PATHNAME + or a JAR-PATHNAME. + +3. Namestrings should all "round-trip": + + (when (typep p 'pathname) + (equal (namestring p) + (namestring (pathname p)))) + + Status ------ This design has been implemented. + History ------- 26 NOV 2010 Changed implemenation to use URI encodings for the "file" schemes including those nested with the "jar" scheme by like aka. "jar:file:/location/of/some.jar!/". + +21 JUN 2011 Fixed implementation to properly handle URI encodings + refering nested jar archive. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Tue Jun 21 01:30:25 2011 (r13352) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Tue Jun 21 03:11:10 2011 (r13353) @@ -153,12 +153,12 @@ if (Utilities.checkZipFile(truename)) { String n = truename.getNamestring(); - n = Pathname.uriEncode(n); + String name = Pathname.uriEncode(truename.name.getStringValue()); if (n.startsWith("jar:")) { - n = "jar:" + n + "!/" + truename.name.getStringValue() + "." + n = "jar:" + n + "!/" + name + "." + COMPILE_FILE_INIT_FASL_TYPE; } else { - n = "jar:file:" + n + "!/" + truename.name.getStringValue() + "." + n = "jar:file:" + n + "!/" + name + "." + COMPILE_FILE_INIT_FASL_TYPE; } mergedPathname = new Pathname(n); Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java Tue Jun 21 01:30:25 2011 (r13352) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Tue Jun 21 03:11:10 2011 (r13353) @@ -280,11 +280,11 @@ url = new URL("file:" + file); uri = url.toURI(); } catch (MalformedURLException e1) { - error(new FileError("Failed to create URI from " + error(new SimpleError("Failed to create URI from " + "'" + file + "'" + ": " + e1.getMessage())); } catch (URISyntaxException e2) { - error(new FileError("Failed to create URI from " + error(new SimpleError("Failed to create URI from " + "'" + file + "'" + ": " + e2.getMessage())); } @@ -326,7 +326,7 @@ try { url = new URL(jarURL); } catch (MalformedURLException ex) { - error(new FileError("Failed to parse URL " + error(new LispError("Failed to parse URL " + "'" + jarURL + "'" + ex.getMessage())); } @@ -339,7 +339,7 @@ device = d.device; } s = "/" + s.substring(separatorIndex + jarSeparator.length()); - Pathname p = new Pathname(s); + Pathname p = new Pathname("file:" + s); // Use URI escaping rules directory = p.directory; name = p.name; type = p.type; @@ -361,13 +361,13 @@ try { uri = url.toURI(); } catch (URISyntaxException ex) { - error(new FileError("Improper URI syntax for " + error(new SimpleError("Improper URI syntax for " + "'" + url.toString() + "'" + ": " + ex.toString())); } final String uriPath = uri.getPath(); if (null == uriPath) { - error(new FileError("The URI has no path: " + uri)); + error(new LispError("The URI has no path: " + uri)); } final File file = new File(uriPath); final Pathname p = new Pathname(file.getPath()); @@ -2487,9 +2487,8 @@ } catch (URISyntaxException e) {} return null; // Error } - - - @DocString(name="uri-encode", + + @DocString(name="uri-encode", args="string => string", doc="Encode percent escape sequences in the manner of URI encodings.") private static final Primitive URI_ENCODE = new pf_uri_encode(); Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Tue Jun 21 01:30:25 2011 (r13352) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Tue Jun 21 03:11:10 2011 (r13353) @@ -116,9 +116,13 @@ (jar-file-init)) , at body))) +(defun jar-pathname-escaped (jar path) + (pathname (format nil "jar:file:~A!/~A" + (ext:uri-encode (namestring jar)) path))) + (defmacro load-from-jar (jar path) `(with-jar-file-init - (load (format nil "jar:file:~A!/~A" ,jar ,path)))) + (load (jar-pathname-escaped ,jar ,path)))) (deftest jar-pathname.load.1 (load-from-jar *tmp-jar-path* "foo") @@ -136,7 +140,7 @@ (load-from-jar *tmp-jar-path* "eek") t) -(deftest jar-pathname.load.5 +?u(deftest jar-pathname.load.5 (load-from-jar *tmp-jar-path* "eek.lisp") t) @@ -169,15 +173,19 @@ t) (deftest jar-pathname.load.13 - (load-from-jar *tmp-jar-path* "a/b/foo bar.abcl") + (signals-error + (load-from-jar *tmp-jar-path* "a/b/foo bar.abcl") + 'error) t) (deftest jar-pathname.load.14 - (load-from-jar *tmp-jar-path-whitespace* "a/b/foo.abcl") + (load-from-jar *tmp-jar-path-whitespace* "a/b/bar.abcl") t) (deftest jar-pathname.load.15 - (load-from-jar *tmp-jar-path-whitespace* "a/b/foo bar.abcl") + (signals-error + (load-from-jar *tmp-jar-path-whitespace* "a/b/foo bar.abcl") + 'error) t) (deftest jar-pathname.load.16 @@ -279,7 +287,7 @@ (deftest jar-pathname.merge-pathnames.2 (merge-pathnames - "bar.abcl" #p"jar:file:baz.jar!/foo/") + "bar.abcl" #p"jar:file:baz.jar!/foo/baz") #p"jar:file:baz.jar!/foo/bar.abcl") (deftest jar-pathname.merge-pathnames.3 @@ -404,7 +412,7 @@ (let ((s "jar:file:/foo/bar/a space/that!/this")) (equal s (namestring (pathname s)))) - 'file-error) + 'error) t) (deftest jar-pathname.11 From mevenson at common-lisp.net Tue Jun 21 21:18:43 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 21 Jun 2011 14:18:43 -0700 Subject: [armedbear-cvs] r13354 - in trunk/abcl/contrib/abcl-asdf: . tests Message-ID: Author: mevenson Date: Tue Jun 21 14:18:43 2011 New Revision: 13354 Log: Incorrect start on Maven repository saved for posterity. Added: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Tue Jun 21 03:11:10 2011 (r13353) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Tue Jun 21 14:18:43 2011 (r13354) @@ -3,7 +3,8 @@ (defsystem :abcl-asdf :author "Mark Evenson" - :version "0.1.0" + :version "0.2.0" :components ((:module base :pathname "" :components - ((:file "abcl-asdf"))))) \ No newline at end of file + ((:file "abcl-asdf") + (:file "maven-embedder" :depends-on ("abcl-asdf")))))) Added: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Tue Jun 21 14:18:43 2011 (r13354) @@ -0,0 +1,112 @@ +(in-package :abcl-asdf) + +(require :abcl-contrib) +(require :jss) + +(defvar *mvn-directory* + "/export/home/evenson/work/apache-maven-3.0.3/lib/" + "Location of 'maven-core-3..

.jar', 'maven-embedder-3..

.jar' etc.") + +(defun init () + (jss:add-directory-jars-to-class-path *mvn-directory* nil)) + +(defconstant +null+ + (java:make-immediate-object :ref nil)) + +(defun resolve (group-id artifact-id version) + (let* ((configuration (find-configuration)) + (embedder (jss:new 'MavenEmbedder configuration)) + (artifact (#"create" embedder group-id version +null+ "jar"))) + (pathname (#"toString" (#"getFile" artifact))))) + +(defun find-configuration ()) + + + + +#| +// http://developers-blog.org/blog/default/2009/09/18/How-to-resolve-an-artifact-with-maven-embedder + +import java.util.ArrayList; + +import java.util.List; +import org.apache.log4j.Logger; +import org.apache.maven.artifact.Artifact; +import org.apache.maven.artifact.repository.ArtifactRepository; +import org.apache.maven.artifact.repository.DefaultArtifactRepository; +import org.apache.maven.artifact.repository.layout.DefaultRepositoryLayout; +import org.apache.maven.artifact.resolver.ArtifactNotFoundException; +import org.apache.maven.artifact.resolver.ArtifactResolutionException; +import org.apache.maven.embedder.Configuration; +import org.apache.maven.embedder.ConfigurationValidationResult; +import org.apache.maven.embedder.DefaultConfiguration; +import org.apache.maven.embedder.MavenEmbedder; +import org.apache.maven.embedder.MavenEmbedderException; +import org.apache.maven.model.Profile; +import org.apache.maven.model.Repository; +import org.apache.maven.settings.SettingsUtils; + + +/** + * resolve artifact. + * @param groupId group id of artifact + * @param artifactId artifact id of artifact + * @param version version of artifact + * @return downloaded artifact file + * @throws HostingOrderException error occured during resolution + */ + +public File resolveArtifact(String groupId, String artifactId, String version) + throws Exception +{ + LOG.debug("request to resolve '" + groupId + ":" + + artifactId + ":" + version + "'"); + Artifact artifact = null; + LOG.debug("using settings: " + this.settingsFile); + File settings = new File(this.getClass().getClassLoader() + .getResource(this.settingsFile).getFile()); + Configuration configuration = new DefaultConfiguration() + .setGlobalSettingsFile(SETTINGS) + .setClassLoader(this.classLoader); + ConfigurationValidationResult validationResult = + MavenEmbedder.validateConfiguration(configuration); + if (validationResult.isValid()) { + try { + MavenEmbedder embedder = new MavenEmbedder(configuration); + artifact = embedder.createArtifact(groupId, + artifactId, version, null, "jar"); + // assign repos, + List repos = new ArrayList(); + Profile profile = SettingsUtils.convertFromSettingsProfile((org.apache.maven.settings.Profile) + embedder.getSettings().getProfiles().get(0)); + for (Repository r : (List < Repository > ) profile. + getRepositories()) { + ArtifactRepository repo = new DefaultArtifactRepository(r.getId(), + r.getUrl(), + new DefaultRepositoryLayout()); + repos.add(repo); + LOG.debug("added repo " + r.getId() + ":" + + r.getUrl()); + } + embedder.resolve(artifact, repos, + embedder.getLocalRepository()); + } catch (MavenEmbedderException mee) { + } catch (ArtifactResolutionException are) { + } catch (ArtifactNotFoundException ane) { + } finally { + configuration = null; + validationResult = null; + } + LOG.info(artifact.getFile().getPath()); + return artifact.getFile(); + } else { + LOG.error("settings file did not validate !!"); + if (!validationResult.isUserSettingsFilePresent()) { + LOG.warn("The specific user settings file "' + settings + "' is not present.); + } else if (!validationResult.isUserSettingsFileParses()) { + LOG.warn("Please check your settings file, it is not well formed XML."); + } + } + return null; +} +|# \ No newline at end of file Modified: trunk/abcl/contrib/abcl-asdf/tests/log4j.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Tue Jun 21 03:11:10 2011 (r13353) +++ trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Tue Jun 21 14:18:43 2011 (r13354) @@ -3,7 +3,7 @@ (defsystem :log4j :components - ((:mvn "log4j" :version "1.4.9") + ((:mvn "log4j/log4j" :version "1.4.9") (:module src :pathname "") ((:file "example")))) From mevenson at common-lisp.net Tue Jun 21 21:18:52 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 21 Jun 2011 14:18:52 -0700 Subject: [armedbear-cvs] r13355 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Tue Jun 21 14:18:51 2011 New Revision: 13355 Log: ASDF-ABCL:RESOLVE returns Maven dependencies from local repository. I don't think the download portion is quite working yet. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Tue Jun 21 14:18:43 2011 (r13354) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Tue Jun 21 14:18:51 2011 (r13355) @@ -4,6 +4,7 @@ (defsystem :abcl-asdf :author "Mark Evenson" :version "0.2.0" + :depends-on ("jss") ;;; XXX move the JSS ASDf defintions here? uggh. :components ((:module base :pathname "" :components ((:file "abcl-asdf") Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Tue Jun 21 14:18:43 2011 (r13354) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Tue Jun 21 14:18:51 2011 (r13355) @@ -1,112 +1,140 @@ +;;; Use the Aether system in a default maven distribution to download +;;; and install dependencies. +;;; +;;; https://docs.sonatype.org/display/AETHER/Home +;;; + (in-package :abcl-asdf) (require :abcl-contrib) (require :jss) -(defvar *mvn-directory* +(defparameter *mvn-directory* "/export/home/evenson/work/apache-maven-3.0.3/lib/" "Location of 'maven-core-3..

.jar', 'maven-embedder-3..

.jar' etc.") (defun init () + (unless (probe-file *mvn-directory*) + (error "You must download Maven 3 from http://maven.apache.org/download.html, then set ABCL-ASDF:*MVN-DIRECTORY* appropiately.")) (jss:add-directory-jars-to-class-path *mvn-directory* nil)) -(defconstant +null+ - (java:make-immediate-object :ref nil)) +(defun repository-system () + (let ((locator + (java:jnew "org.apache.maven.repository.internal.DefaultServiceLocator")) + (wagon-class + (java:jclass "org.sonatype.aether.connector.wagon.WagonProvider")) + (wagon-provider + (jss:find-java-class "LightweightHttpWagon")) + (repository-connector-factory-class + (java:jclass "org.sonatype.aether.connector.wagon.WagonRepositoryConnector")) + (wagon-repository-connector-factory-class + (java:jclass "org.sonatype.aether.connector.wagon.WagonRepositoryConnectorFactory")) + (repository-system-class + (java:jclass "org.sonatype.aether.RepositorySystem"))) + (#"setService" locator wagon-class wagon-provider) + (#"addService" locator + repository-connector-factory-class + wagon-repository-connector-factory-class) + (#"getService" locator repository-system-class))) + +#| +private static RepositorySystem newRepositorySystem() +{ + DefaultServiceLocator locator = new DefaultServiceLocator(); + locator.setServices( WagonProvider.class, new ManualWagonProvider() ); + locator.addService( RepositoryConnectorFactory.class, WagonRepositoryConnectorFactory.class ); + + return locator.getService( RepositorySystem.class ); +} +|# + +(defun new-session (repository-system) + (let ((session + (java:jnew (jss:find-java-class "MavenRepositorySystemSession"))) + (local-repository + (java:jnew (jss:find-java-class "LocalRepository") + (namestring (merge-pathnames ".m2/repository/" + (user-homedir-pathname)))))) + (#"setLocalRepositoryManager" + session + (#"newLocalRepositoryManager" repository-system local-repository)))) + +#| +private static RepositorySystemSession newSession( RepositorySystem system ) +{ + MavenRepositorySystemSession session = new MavenRepositorySystemSession(); + + LocalRepository localRepo = new LocalRepository( "target/local-repo" ); + session.setLocalRepositoryManager( system.newLocalRepositoryManager( localRepo ) ); + + return session; +} +|# + +;;; XXX make-immediate-object is deprecated +(defconstant +null+ (java:make-immediate-object nil :ref)) (defun resolve (group-id artifact-id version) - (let* ((configuration (find-configuration)) - (embedder (jss:new 'MavenEmbedder configuration)) - (artifact (#"create" embedder group-id version +null+ "jar"))) - (pathname (#"toString" (#"getFile" artifact))))) + (let* ((system + (repository-system)) + (session + (new-session system)) + (artifact + (java:jnew (jss:find-java-class "aether.util.artifact.DefaultArtifact") + (format nil "~A:~A:~A" + group-id artifact-id version))) + (dependency + (java:jnew (jss:find-java-class "aether.graph.Dependency") + artifact "compile")) + (central + (java:jnew (jss:find-java-class "RemoteRepository") + "central" "default" + "http://repo1.maven.org/maven2/")) + (collect-request (java:jnew (jss:find-java-class "CollectRequest")))) + (#"setRoot" collect-request dependency) + (#"addRepository" collect-request central) + (let* ((node + (#"getRoot" (#"collectDependencies" system session collect-request))) + (dependency-request + (java:jnew (jss:find-java-class "DependencyRequest") + node +null+)) + (nlg + (java:jnew (jss:find-java-class "PreorderNodeListGenerator")))) + (#"resolveDependencies" system session dependency-request) + (#"accept" node nlg) + (#"getClassPath" nlg)))) -(defun find-configuration ()) +#| +public static void main( String[] args ) + throws Exception +{ + RepositorySystem repoSystem = newRepositorySystem(); + RepositorySystemSession session = newSession( repoSystem ); + Dependency dependency = + new Dependency( new DefaultArtifact( "org.apache.maven:maven-profile:2.2.1" ), "compile" ); + RemoteRepository central = new RemoteRepository( "central", "default", "http://repo1.maven.org/maven2/" ); + CollectRequest collectRequest = new CollectRequest(); + collectRequest.setRoot( dependency ); + collectRequest.addRepository( central ); + DependencyNode node = repoSystem.collectDependencies( session, collectRequest ).getRoot(); -#| -// http://developers-blog.org/blog/default/2009/09/18/How-to-resolve-an-artifact-with-maven-embedder + DependencyRequest dependencyRequest = new DependencyRequest( node, null ); + + repoSystem.resolveDependencies( session, dependencyRequest ); + + PreorderNodeListGenerator nlg = new PreorderNodeListGenerator(); + node.accept( nlg ); + System.out.println( nlg.getClassPath() ); +} +|# + +#| -import java.util.ArrayList; +Test: -import java.util.List; -import org.apache.log4j.Logger; -import org.apache.maven.artifact.Artifact; -import org.apache.maven.artifact.repository.ArtifactRepository; -import org.apache.maven.artifact.repository.DefaultArtifactRepository; -import org.apache.maven.artifact.repository.layout.DefaultRepositoryLayout; -import org.apache.maven.artifact.resolver.ArtifactNotFoundException; -import org.apache.maven.artifact.resolver.ArtifactResolutionException; -import org.apache.maven.embedder.Configuration; -import org.apache.maven.embedder.ConfigurationValidationResult; -import org.apache.maven.embedder.DefaultConfiguration; -import org.apache.maven.embedder.MavenEmbedder; -import org.apache.maven.embedder.MavenEmbedderException; -import org.apache.maven.model.Profile; -import org.apache.maven.model.Repository; -import org.apache.maven.settings.SettingsUtils; - - -/** - * resolve artifact. - * @param groupId group id of artifact - * @param artifactId artifact id of artifact - * @param version version of artifact - * @return downloaded artifact file - * @throws HostingOrderException error occured during resolution - */ - -public File resolveArtifact(String groupId, String artifactId, String version) - throws Exception -{ - LOG.debug("request to resolve '" + groupId + ":" - + artifactId + ":" + version + "'"); - Artifact artifact = null; - LOG.debug("using settings: " + this.settingsFile); - File settings = new File(this.getClass().getClassLoader() - .getResource(this.settingsFile).getFile()); - Configuration configuration = new DefaultConfiguration() - .setGlobalSettingsFile(SETTINGS) - .setClassLoader(this.classLoader); - ConfigurationValidationResult validationResult = - MavenEmbedder.validateConfiguration(configuration); - if (validationResult.isValid()) { - try { - MavenEmbedder embedder = new MavenEmbedder(configuration); - artifact = embedder.createArtifact(groupId, - artifactId, version, null, "jar"); - // assign repos, - List repos = new ArrayList(); - Profile profile = SettingsUtils.convertFromSettingsProfile((org.apache.maven.settings.Profile) - embedder.getSettings().getProfiles().get(0)); - for (Repository r : (List < Repository > ) profile. - getRepositories()) { - ArtifactRepository repo = new DefaultArtifactRepository(r.getId(), - r.getUrl(), - new DefaultRepositoryLayout()); - repos.add(repo); - LOG.debug("added repo " + r.getId() + ":" - + r.getUrl()); - } - embedder.resolve(artifact, repos, - embedder.getLocalRepository()); - } catch (MavenEmbedderException mee) { - } catch (ArtifactResolutionException are) { - } catch (ArtifactNotFoundException ane) { - } finally { - configuration = null; - validationResult = null; - } - LOG.info(artifact.getFile().getPath()); - return artifact.getFile(); - } else { - LOG.error("settings file did not validate !!"); - if (!validationResult.isUserSettingsFilePresent()) { - LOG.warn("The specific user settings file "' + settings + "' is not present.); - } else if (!validationResult.isUserSettingsFileParses()) { - LOG.warn("Please check your settings file, it is not well formed XML."); - } - } - return null; -} +(init) +(resolve "org.slf4j" "slf4j-api" "1.6.1") |# \ No newline at end of file From mevenson at common-lisp.net Wed Jun 22 08:17:46 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 22 Jun 2011 01:17:46 -0700 Subject: [armedbear-cvs] r13356 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jun 22 01:17:45 2011 New Revision: 13356 Log: Report load time of ".abclrc" forms if we are being chatty. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java Tue Jun 21 14:18:51 2011 (r13355) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Wed Jun 22 01:17:45 2011 (r13356) @@ -215,7 +215,15 @@ String userHome = System.getProperty("user.home"); File file = new File(userHome, ".abclrc"); if (file.isFile()) { + final double startLoad = System.currentTimeMillis(); Load.load(file.getCanonicalPath()); + if (!noinform) { + final double loadtime + = (System.currentTimeMillis() - startLoad) / 1000.0; + getStandardOutput() + ._writeString("Loading " + file + " completed in " + + loadtime + " seconds.\n"); + } return; } } From mevenson at common-lisp.net Wed Jun 22 10:38:26 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 22 Jun 2011 03:38:26 -0700 Subject: [armedbear-cvs] r13357 - trunk/abcl Message-ID: Author: mevenson Date: Wed Jun 22 03:38:25 2011 New Revision: 13357 Log: Another stab at fixing the build version which was failing on incomplete compiles. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Wed Jun 22 01:17:45 2011 (r13356) +++ trunk/abcl/build.xml Wed Jun 22 03:38:25 2011 (r13357) @@ -258,6 +258,8 @@ + @@ -356,8 +358,6 @@ - Author: mevenson Date: Wed Jun 22 03:38:34 2011 New Revision: 13358 Log: Convert to use @DocString annotation adding documentation. 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 Wed Jun 22 03:38:25 2011 (r13357) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Wed Jun 22 03:38:34 2011 (r13358) @@ -67,10 +67,15 @@ 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. - * We could do this with setter/getters, but that choose not to in order to avoid the + /** 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. We could do this with + * setter/getters, but that choose not to in order to avoid the * performance indirection penalty. + * + * TODO There is no "perfomance penalty" in contemporary + * compilers which inline such access, so it would be better to + * implement this as setter/getter ME 20110622 * * Although, given the number of bugs that crop up when this * protocol is not adhered to, maybe we should consider it. @@ -79,8 +84,11 @@ namestring = null; } - // ### %invalidate-namestring - private static final Primitive _INVALIDATE_NAMESTRING = new pf_invalidate_namestring(); + private static final Primitive _INVALIDATE_NAMESTRING + = new pf_invalidate_namestring(); + @DocString(name="%invalidate-namestring", + args="pathname", + returns="pathname") private static class pf_invalidate_namestring extends Primitive { pf_invalidate_namestring() { super("%invalidate-namestring", PACKAGE_EXT, false); @@ -789,7 +797,9 @@ return sb.toString(); } - /** @return The representation of this pathname suitable for referencing an entry in a Zip/JAR file */ + /** @return The representation of this pathname suitable for + * referencing an entry in a Zip/JAR file + */ protected String asEntryPath() { Pathname p = new Pathname(); p.directory = directory; @@ -1078,68 +1088,73 @@ Keyword.LOCAL)); } } - // ### %pathname-host + private static final Primitive _PATHNAME_HOST = new pf_pathname_host(); + @DocString(name="%pathname-host") private static class pf_pathname_host extends Primitive { pf_pathname_host() { super("%pathname-host", PACKAGE_SYS, false); } @Override public LispObject execute(LispObject first, LispObject second) { - checkCaseArgument(second); + checkCaseArgument(second); // FIXME Why is this ignored? return coerceToPathname(first).host; } } - // ### %pathname-device private static final Primitive _PATHNAME_DEVICE = new pf_pathname_device(); + @DocString(name="%pathname-device") private static class pf_pathname_device extends Primitive { pf_pathname_device() { super("%pathname-device", PACKAGE_SYS, false); } @Override public LispObject execute(LispObject first, LispObject second) { - checkCaseArgument(second); + checkCaseArgument(second); // FIXME Why is this ignored? return coerceToPathname(first).device; } } - // ### %pathname-directory private static final Primitive _PATHNAME_DIRECTORY = new pf_pathname_directory(); + @DocString(name="%pathname-directory") private static class pf_pathname_directory extends Primitive { pf_pathname_directory() { super("%pathname-directory", PACKAGE_SYS, false); } @Override public LispObject execute(LispObject first, LispObject second) { - checkCaseArgument(second); + checkCaseArgument(second); // FIXME Why is this ignored? return coerceToPathname(first).directory; } } - // ### %pathname-name private static final Primitive _PATHNAME_NAME = new pf_pathname_name(); + @DocString(name="%pathname-name") private static class pf_pathname_name extends Primitive { pf_pathname_name() { super ("%pathname-name", PACKAGE_SYS, false); } @Override public LispObject execute(LispObject first, LispObject second) { - checkCaseArgument(second); + checkCaseArgument(second); // FIXME Why is this ignored? return coerceToPathname(first).name; } } - // ### %pathname-type private static final Primitive _PATHNAME_TYPE = new pf_pathname_type(); + @DocString(name="%pathname-type") private static class pf_pathname_type extends Primitive { pf_pathname_type() { super("%pathname-type", PACKAGE_SYS, false); } @Override public LispObject execute(LispObject first, LispObject second) { - checkCaseArgument(second); + checkCaseArgument(second); // FIXME Why is this ignored? return coerceToPathname(first).type; } } - // ### pathname-version + private static final Primitive PATHNAME_VERSION = new pf_pathname_version(); + @DocString(name="pathname-version", + args="pathname", + returns="version", + doc="Return the version component of PATHNAME.") private static class pf_pathname_version extends Primitive { pf_pathname_version() { super("pathname-version", "pathname"); @@ -1149,9 +1164,16 @@ return coerceToPathname(arg).version; } } - // ### namestring - // namestring pathname => namestring private static final Primitive NAMESTRING = new pf_namestring(); + @DocString(name="namestring", + args="pathname", + returns="namestring", + doc="Returns the NAMESTRING of PATHNAME if it has one.\n" + + "\n" + + "If PATHNAME is of type url-pathname or jar-pathname the NAMESTRING is encoded\n" + + "according to the uri percent escape rules.\n" + + "\n" + + "Signals an error if PATHNAME lacks a printable NAMESTRING representation.\n") private static class pf_namestring extends Primitive { pf_namestring() { super("namestring", "pathname"); @@ -1167,9 +1189,13 @@ return new SimpleString(namestring); } } - // ### directory-namestring - // directory-namestring pathname => namestring + private static final Primitive DIRECTORY_NAMESTRING = new pf_directory_namestring(); + // TODO clarify uri encoding rules in implementation, then document + @DocString(name="directory-namestring", + args="pathname", + returns="namestring", + doc="Returns the NAMESTRING of directory porition of PATHNAME if it has one.") private static class pf_directory_namestring extends Primitive { pf_directory_namestring() { super("directory-namestring", "pathname"); @@ -1179,8 +1205,11 @@ return new SimpleString(coerceToPathname(arg).getDirectoryNamestring()); } } - // ### pathname pathspec => pathname private static final Primitive PATHNAME = new pf_pathname(); + @DocString(name="pathname", + args="pathspec", + returns="pathname", + doc="Returns the PATHNAME denoted by PATHSPEC.") private static class pf_pathname extends Primitive { pf_pathname() { super("pathname", "pathspec"); @@ -1190,8 +1219,10 @@ return coerceToPathname(arg); } } - // ### %parse-namestring string host default-pathname => pathname, position private static final Primitive _PARSE_NAMESTRING = new pf_parse_namestring(); + @DocString(name="%parse-namestring", + args="namestring host default-pathname", + returns="pathname, position") private static class pf_parse_namestring extends Primitive { pf_parse_namestring() { super("%parse-namestring", PACKAGE_SYS, false, @@ -1222,8 +1253,11 @@ namestring.LENGTH()); } } - // ### make-pathname private static final Primitive MAKE_PATHNAME = new pf_make_pathname(); + @DocString(name="make-pathname", + args="&key host device directory name type version defaults case", + returns="pathname", + doc="Constructs and returns a pathname from the supplied keyword arguments.") private static class pf_make_pathname extends Primitive { pf_make_pathname() { super("make-pathname", @@ -1446,8 +1480,11 @@ } return true; } - // ### pathnamep private static final Primitive PATHNAMEP = new pf_pathnamep(); + @DocString(name="pathnamep", + args="object", + returns="generalized-boolean", + doc="Returns true if OBJECT is of type pathname; otherwise, returns false.") private static class pf_pathnamep extends Primitive { pf_pathnamep() { super("pathnamep", "object"); @@ -1457,8 +1494,12 @@ return arg instanceof Pathname ? T : NIL; } } - // ### logical-pathname-p private static final Primitive LOGICAL_PATHNAME_P = new pf_logical_pathname_p(); + @DocString(name="logical-pathname-p", + args="object", + returns="generalized-boolean", + + doc="Returns true if OBJECT is of type logical-pathname; otherwise, returns false.") private static class pf_logical_pathname_p extends Primitive { pf_logical_pathname_p() { super("logical-pathname-p", PACKAGE_SYS, true, "object"); @@ -1468,8 +1509,14 @@ return arg instanceof LogicalPathname ? T : NIL; } } - // ### user-homedir-pathname &optional host => pathname + private static final Primitive USER_HOMEDIR_PATHNAME = new pf_user_homedir_pathname(); + @DocString(name="user-homedir-pathname", + args="&optional host", + returns="pathname", + doc="Determines the pathname that corresponds to the user's home directory.\n" + + "The value returned is obtained from the JVM system propoerty 'user.home'.\n" + + "If HOST is specified, returns NIL.") private static class pf_user_homedir_pathname extends Primitive { pf_user_homedir_pathname() { super("user-homedir-pathname", "&optional host"); @@ -1492,8 +1539,11 @@ } } - // ### list-directory directory private static final Primitive LIST_DIRECTORY = new pf_list_directory(); + @DocString(name="list-directory", + args="directory &optional (resolve-symlinks t)", + returns="pathnames", + doc="Lists the contents of DIRECTORY, optionally resolving symbolic links.") private static class pf_list_directory extends Primitive { pf_list_directory() { super("list-directory", PACKAGE_SYS, true, "directory &optional (resolve-symlinks t)"); @@ -1593,7 +1643,10 @@ } } - // ### match-wild-jar-pathname wild-jar-pathname + @DocString(name="match-wild-jar-pathname", + args="wild-jar-pathname", + returns="pathnames", + doc="Returns the pathnames matching WILD-JAR-PATHNAME which is both wild and a jar-pathname.") static final Primitive MATCH_WILD_JAR_PATHNAME = new pf_match_wild_jar_pathname(); private static class pf_match_wild_jar_pathname extends Primitive { pf_match_wild_jar_pathname() { @@ -1696,12 +1749,14 @@ return false; } - // ### PATHNAME-JAR-P + @DocString(name="pathname-jar-p", + args="pathname", + returns="generalized-boolean", + doc="Predicate functionfor whether PATHNAME references a jar.") private static final Primitive PATHNAME_JAR_P = new pf_pathname_jar_p(); private static class pf_pathname_jar_p extends Primitive { pf_pathname_jar_p() { - super("pathname-jar-p", PACKAGE_EXT, true, "pathname", - "Predicate for whether PATHNAME references a JAR."); + super("pathname-jar-p", PACKAGE_EXT, true); } @Override public LispObject execute(LispObject arg) { @@ -1714,7 +1769,10 @@ return (device instanceof Cons); } - // ### PATHNAME-URL-P + @DocString(name="pathname-url-p", + args="pathname", + returns="generalized-boolean", + doc="Predicate function for whether PATHNAME references a jaurl.") private static final Primitive PATHNAME_URL_P = new pf_pathname_url_p(); private static class pf_pathname_url_p extends Primitive { pf_pathname_url_p() { @@ -1781,8 +1839,15 @@ } return false; } - // ### %wild-pathname-p + private static final Primitive _WILD_PATHNAME_P = new pf_wild_pathname_p(); + @DocString(name="%wild-pathname-p", + args="pathname keyword", + returns="generalized-boolean", + doc="Predicate for determing whether PATHNAME contains wild components.\n" + + "KEYWORD, if non-nil, should be one of :directory, :host, :device,\n" + + ":name, :type, or :version indicating that only the specified component\n" + + "should be checked for wildness.") static final class pf_wild_pathname_p extends Primitive { pf_wild_pathname_p() { super("%wild-pathname-p", PACKAGE_SYS, true); @@ -1827,8 +1892,12 @@ } } - // ### merge-pathnames pathname &optional default-pathname default-version" private static final Primitive MERGE_PATHNAMES = new pf_merge_pathnames(); + @DocString(name="merge-pathnames", + args="pathname &optional default-pathname default-version", + returns="pathname", + doc="Constructs a pathname from PATHNAME by filling in any unsupplied components\n" + + "with the corresponding values from DEFAULT-PATHNAME and DEFAULT-VERSION.") static final class pf_merge_pathnames extends Primitive { pf_merge_pathnames() { super("merge-pathnames", "pathname &optional default-pathname default-version"); @@ -2308,8 +2377,11 @@ return 0; } - // ### mkdir pathname private static final Primitive MKDIR = new pf_mkdir(); + @DocString(name="mkdir", + args="pathname", + returns="generalized-boolean", + doc="Attempts to create directory at PATHNAME returning the success or failure.") private static class pf_mkdir extends Primitive { pf_mkdir() { super("mkdir", PACKAGE_SYS, false, "pathname"); @@ -2337,8 +2409,11 @@ } } - // ### rename-file filespec new-name => defaulted-new-name, old-truename, new-truename private static final Primitive RENAME_FILE = new pf_rename_file(); + @DocString(name="rename-file", + args="filespec new-name", + returns="defaulted-new-name, old-truename, new-truename", + doc="rename-file modifies the file system in such a way that the file indicated by FILESPEC is renamed to DEFAULTED-NEW-NAME.") private static class pf_rename_file extends Primitive { pf_rename_file() { super("rename-file", "filespec new-name"); @@ -2391,9 +2466,13 @@ + ".")); } } - - // ### file-namestring pathname => namestring + + // TODO clarify uri encoding cases in implementation and document private static final Primitive FILE_NAMESTRING = new pf_file_namestring(); + @DocString(name="file-namestring", + args="pathname", + returns="namestring", + doc="Returns just the name, type, and version components of PATHNAME.") private static class pf_file_namestring extends Primitive { pf_file_namestring() { super("file-namestring", "pathname"); @@ -2419,8 +2498,11 @@ } } - // ### host-namestring pathname => namestring private static final Primitive HOST_NAMESTRING = new pf_host_namestring(); + @DocString(name="host-namestring", + args="pathname", + returns="namestring", + doc="Returns the host name of PATHNAME.") private static class pf_host_namestring extends Primitive { pf_host_namestring() { super("host-namestring", "pathname"); @@ -2463,8 +2545,9 @@ @DocString(name="uri-decode", - args="string => string", - doc="Decode percent escape sequences in the manner of URI encodings.") + args="string", + returns="string", + doc="Decode STRING percent escape sequences in the manner of URI encodings.") private static final Primitive URI_DECODE = new pf_uri_decode(); private static final class pf_uri_decode extends Primitive { pf_uri_decode() { @@ -2488,9 +2571,10 @@ return null; // Error } - @DocString(name="uri-encode", - args="string => string", - doc="Encode percent escape sequences in the manner of URI encodings.") + @DocString(name="uri-encode", + args="string", + returns="string", + doc="Encode percent escape sequences in the manner of URI encodings.") private static final Primitive URI_ENCODE = new pf_uri_encode(); private static final class pf_uri_encode extends Primitive { pf_uri_encode() { From mevenson at common-lisp.net Wed Jun 22 12:25:29 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 22 Jun 2011 05:25:29 -0700 Subject: [armedbear-cvs] r13359 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jun 22 05:25:28 2011 New Revision: 13359 Log: Created +NULL+, +TRUE+, and +FALSE+ constants in the JAVA package. Deprecate JAVA:MAKE-IMMEDIATE-OBJECT in favor of using these constants in the JAVA package for the associated wrapped primitive types. Modified: trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/JavaObject.java Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java Wed Jun 22 03:38:34 2011 (r13358) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Wed Jun 22 05:25:28 2011 (r13359) @@ -1085,12 +1085,18 @@ } } + // DEPRECATED Remove MAKE-IMMEDIATE-OBJECT in abcl-0.29 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.") + 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.\n" + + "\n" + + "Deprecated. Please use JAVA:+NULL+, JAVA:+TRUE+, and JAVA:+FALSE+ for\n" + + "constructing wrapped primitive types, JAVA:JOBJECT-LISP-VALUE for converting a\n" + + "JAVA:JAVA-OBJECT to a Lisp value, or JAVA:JNULL_REF_P to distinguish a wrapped\n" + + "null JAVA_OBJECT from nil.") private static final class pf_make_immediate_object extends Primitive { pf_make_immediate_object() @@ -1101,6 +1107,8 @@ @Override public LispObject execute(LispObject[] args) { + Symbol.WARN.getSymbolFunction() + .execute(new SimpleString("JAVA:MAKE-IMMEDIATE-OBJECT is deprecated.")); if (args.length < 1) error(new WrongNumberOfArgumentsException(this)); LispObject object = args[0]; Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java Wed Jun 22 03:38:34 2011 (r13358) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Wed Jun 22 05:25:28 2011 (r13359) @@ -659,4 +659,10 @@ }; + public final static Symbol NULL + = Lisp.exportConstant("+NULL+", PACKAGE_JAVA, new JavaObject(null)); + public final static Symbol TRUE + = Lisp.exportConstant("+TRUE+", PACKAGE_JAVA, new JavaObject(true)); + public final static Symbol FALSE + = Lisp.exportConstant("+FALSE+", PACKAGE_JAVA, new JavaObject(false)); } From mevenson at common-lisp.net Wed Jun 22 12:59:41 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 22 Jun 2011 05:59:41 -0700 Subject: [armedbear-cvs] r13360 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Wed Jun 22 05:59:41 2011 New Revision: 13360 Log: jss-2.0.1 remove use of MAKE-IMMEDIATE-OBJECT. Modified: trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/jss.asd Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Wed Jun 22 05:25:28 2011 (r13359) +++ trunk/abcl/contrib/jss/invoke.lisp Wed Jun 22 05:59:41 2011 (r13360) @@ -176,8 +176,6 @@ (apply #'jstatic method object-as-class args) (apply #'jcall method object args)))))) -(defconstant +true+ (make-immediate-object t :boolean)) - ;;; Method name as String --> String | Symbol --> jmethod (defvar *methods-cache* (make-hash-table :test #'equal)) @@ -630,8 +628,7 @@ if (evenp i) do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m else - do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m))) -#+nil (null (make-immediate-object nil :ref))) + do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m)))) (let ((safe-method-names-and-defs (loop for (name function) on method-names-and-defs by #'cddr collect name collect (safely function name)))) Modified: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- trunk/abcl/contrib/jss/jss.asd Wed Jun 22 05:25:28 2011 (r13359) +++ trunk/abcl/contrib/jss/jss.asd Wed Jun 22 05:59:41 2011 (r13360) @@ -3,7 +3,7 @@ (defsystem :jss :author "Alan Ruttenberg, Mark Evenson" - :version "2.0.0" + :version "2.0.1" :components ((:module base :pathname "" :serial t :components ((:file "packages") From mevenson at common-lisp.net Wed Jun 22 13:39:47 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 22 Jun 2011 06:39:47 -0700 Subject: [armedbear-cvs] r13361 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jun 22 06:39:47 2011 New Revision: 13361 Log: Edit RUN-PROGRAM documentation lightly. Modified: trunk/abcl/src/org/armedbear/lisp/run-program.lisp Modified: trunk/abcl/src/org/armedbear/lisp/run-program.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/run-program.lisp Wed Jun 22 05:59:41 2011 (r13360) +++ trunk/abcl/src/org/armedbear/lisp/run-program.lisp Wed Jun 22 06:39:47 2011 (r13361) @@ -33,7 +33,13 @@ (require "JAVA") -;;Vaguely inspired by sb-ext:run-program in SBCL. See . This implementation uses the JVM facilities for running external processes: . +;;; Vaguely inspired by sb-ext:run-program in SBCL. +;;; +;;; See . +;;; +;;; This implementation uses the JVM facilities for running external +;;; processes. +;;; . (defun run-program (program args &key environment (wait t)) ;;For documentation, see below. (let ((pb (%make-process-builder program args))) @@ -48,21 +54,40 @@ process))) (setf (documentation 'run-program 'function) - "run-program creates a new process specified by the program argument. args are the standard arguments that can be passed to a program. For no arguments, use nil (which means that just the name of the program is passed as arg 0). + "Creates a new process running the the PROGRAM. +ARGS are a list of strings to be passed to the program as arguments. -run-program will return a process structure. +For no arguments, use nil which means that just the name of the +program is passed as arg 0. + +Returns a process structure containing the JAVA-OBJECT wrapped Process +object, and the PROCESS-INPUT, PROCESS-OUTPUT, and PROCESS-ERROR streams. + +c.f. http://download.oracle.com/javase/6/docs/api/java/lang/Process.html Notes about Unix environments (as in the :environment): - * The ABCL implementation of run-program, like SBCL, Perl and many other programs, copies the Unix environment by default. - * Running Unix programs from a setuid process, or in any other situation where the Unix environment is under the control of someone else, is a mother lode of security problems. If you are contemplating doing this, read about it first. (The Perl community has a lot of good documentation about this and other security issues in script-like programs.) + * The ABCL implementation of run-program, like SBCL, Perl and many + other programs, copies the Unix environment by default. + + * Running Unix programs from a setuid process, or in any other + situation where the Unix environment is under the control of + someone else, is a mother lode of security problems. If you are + contemplating doing this, read about it first. (The Perl + community has a lot of good documentation about this and other + security issues in script-like programs.) The &key arguments have the following meanings: -:environment - a alist of STRINGs (name . value) describing the new environment. The default is to copy the environment of the current process. -:wait - If non-NIL (default), wait until the created process finishes. If nil, continue running Lisp until the program finishes.") +:environment + An alist of STRINGs (name . value) describing the new + environment. The default is to copy the environment of the current + process. + +:wait + If non-NIL, which is the default, wait until the created process + finishes. If NIL, continue running Lisp until the program + finishes.") ;;The process structure. @@ -92,10 +117,10 @@ "Kills the process." (%process-kill (process-jprocess process))) -;;Low-level functions. For now they're just a refactoring of the initial implementation with direct -;;jnew & jcall forms in the code. As per Ville's suggestion, these should really be implemented as -;;primitives. - +;;; Low-level functions. For now they're just a refactoring of the +;;; initial implementation with direct jnew & jcall forms in the +;;; code. As per Ville's suggestion, these should really be implemented +;;; as primitives. (defun %make-process-builder (program args) (java:jnew "java.lang.ProcessBuilder" (java:jnew-array-from-list "java.lang.String" (cons program args)))) From mevenson at common-lisp.net Wed Jun 22 14:33:55 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 22 Jun 2011 07:33:55 -0700 Subject: [armedbear-cvs] r13362 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Wed Jun 22 07:33:55 2011 New Revision: 13362 Log: Dynamically find location of mvn libraries based on 'mvn' in PATH. Will not work under win32 without an analog for UNIX 'which'. Require maven-3.0.3 or greater as the Aether API for maven-3.0.2 does not seem to have the same classes (ugh!). Still does not seem to resolve dependencies that are not already present in the local repository. Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Wed Jun 22 06:39:47 2011 (r13361) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Wed Jun 22 07:33:55 2011 (r13362) @@ -9,16 +9,72 @@ (require :abcl-contrib) (require :jss) -(defparameter *mvn-directory* - "/export/home/evenson/work/apache-maven-3.0.3/lib/" +#| +Test: + +(resolve "org.slf4j" "slf4j-api" "1.6.1") +|# + +(defvar *mavens* '("/opt/local/bin/mvn3" "mvn3" "mvn")) + +(defun find-mvn () + (dolist (mvn-path *mavens*) + (let ((mvn + (handler-case + (truename (read-line (sys::process-output + (sys::run-program "which" `(,mvn-path))))) + ('end-of-file () + nil)))) + (when mvn + (return-from find-mvn mvn))))) + +(defun find-mvn-libs () + (let ((mvn (find-mvn))) + (unless mvn + (warn "Failed to find Maven3 libraries.") + (return-from find-mvn-libs)) + (truename (make-pathname + :defaults (merge-pathnames "../lib/" mvn) + :name nil :type nil)))) + +(defparameter *mvn-libs-directory* + nil "Location of 'maven-core-3..

.jar', 'maven-embedder-3..

.jar' etc.") -(defun init () - (unless (probe-file *mvn-directory*) - (error "You must download Maven 3 from http://maven.apache.org/download.html, then set ABCL-ASDF:*MVN-DIRECTORY* appropiately.")) - (jss:add-directory-jars-to-class-path *mvn-directory* nil)) +(defun mvn-version () + (let ((line + (read-line (sys::process-output (sys::run-program + (namestring (find-mvn)) '("-version"))))) + (prefix "Apache Maven ")) + + (unless (eql (search prefix line) 0) + (return-from mvn-version nil)) + (let ((version (subseq line (length prefix)))) + version))) + +;;; XXX will break with release of Maven 3.1.x +(defun ensure-mvn-version () + "Return t if Maven version is 3.0.3 or greater." + (let ((version-string (mvn-version))) + (and (search "3.0" version-string) + (>= (parse-integer (subseq version-string + 4 (search " (" version-string))) + 3)))) + +(defparameter *init* nil) + +(defun init () + (unless *mvn-libs-directory* + (setf *mvn-libs-directory* (find-mvn-libs))) + (unless (probe-file *mvn-libs-directory*) + (error "You must download maven-3.0.3 from http://maven.apache.org/download.html, then set ABCL-ASDF:*MVN-DIRECTORY* appropiately.")) + (unless (ensure-mvn-version) + (error "We need maven-3.0.3 or later.")) + (jss:add-directory-jars-to-class-path *mvn-libs-directory* nil) + (setf *init* t)) (defun repository-system () + (unless *init* (init)) (let ((locator (java:jnew "org.apache.maven.repository.internal.DefaultServiceLocator")) (wagon-class @@ -71,10 +127,8 @@ } |# -;;; XXX make-immediate-object is deprecated -(defconstant +null+ (java:make-immediate-object nil :ref)) - (defun resolve (group-id artifact-id version) + (unless *init* (init)) (let* ((system (repository-system)) (session @@ -97,7 +151,7 @@ (#"getRoot" (#"collectDependencies" system session collect-request))) (dependency-request (java:jnew (jss:find-java-class "DependencyRequest") - node +null+)) + node java:+null+)) (nlg (java:jnew (jss:find-java-class "PreorderNodeListGenerator")))) (#"resolveDependencies" system session dependency-request) @@ -131,10 +185,3 @@ } |# -#| - -Test: - -(init) -(resolve "org.slf4j" "slf4j-api" "1.6.1") -|# \ No newline at end of file From mevenson at common-lisp.net Mon Jun 27 10:23:24 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 27 Jun 2011 03:23:24 -0700 Subject: [armedbear-cvs] r13363 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Mon Jun 27 03:23:23 2011 New Revision: 13363 Log: Export JCMN and JAPROPOS. Start documentation by copying the beginning of invoke.jss over to README.markdown. Added: trunk/abcl/contrib/jss/README.markdown Modified: trunk/abcl/contrib/jss/packages.lisp Added: trunk/abcl/contrib/jss/README.markdown ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jss/README.markdown Mon Jun 27 03:23:23 2011 (r13363) @@ -0,0 +1,63 @@ +JSS +=== + +Created by Alan Ruttenburg + + +JSS stands for either "Java Simple Syntax" or "Java Syntax Sucks", +depending on your mood. + +The dynamic dispatch of the java.lang.reflect package is used to make +it real easy, if perhaps less efficient, to write Java code since you +don't need to be bothered with imports, or with figuring out which +method to call. The only time that you need to know a class name is +when you want to call a static method, or a constructor, and in those +cases, you only need to know enough of the class name that is unique +wrt to the classes on your classpath. + +Java methods look like this: #"toString". Java classes are represented +as symbols, which are resolved to the appropriate java class +name. When ambiguous, you need to be more specific. A simple example: + + (let ((sw (new 'StringWriter))) + (#"write" sw "Hello ") + (#"write" sw "World") + (print (#"toString" sw))) + +What's happened here? First, all the classes in all the jars in the +classpath have been collected. For each class a.b.C.d, we have +recorded that b.c.d, b.C.d, C.d, c.d, and d potentially refer to this +class. In your call to new, as long as the symbol can refer to only +one class, we use that class. In this case, it is +java.io.StringWriter. You could also have written (new +'io.stringwriter), (new '|io.StringWriter|), (new +'java.io.StringWriter)... + +the call (#"write" sw "Hello "), uses the code in invoke.java to +call the method named "write" with the arguments sw and "Hello ". +JSS figures out the right java method to call, and calls it. + +If you want to do a raw java call, use #0"toString". Raw calls +return their results as Java objects, avoiding doing the usual Java +object to Lisp object conversions that ABCL does. + +(with-constant-signature ((name jname raw?)*) &body body) +binds a macro which expands to a jcall, promising that the same method +will be called every time. Use this if you are making a lot of calls and +want to avoid the overhead of a the dynamic dispatch. +e.g. (with-constant-signature ((tostring "toString")) + (time (dotimes (i 10000) (tostring "foo")))) +runs about 3x faster than (time (dotimes (i 10000) (#"toString" "foo"))) + +(with-constant-signature ((tostring "toString" t)) ...) will cause the +toString to be a raw java call. see get-all-jar-classnames below for +an example. + +Implementation is that the first time the function is called, the +method is looked up based on the arguments passed, and thereafter +that method is called directly. Doesn't work for static methods at +the moment (lazy) + +(japropos string) finds all class names matching string + +(jcmn class-name) lists the names of all methods for the class Modified: trunk/abcl/contrib/jss/packages.lisp ============================================================================== --- trunk/abcl/contrib/jss/packages.lisp Wed Jun 22 07:33:55 2011 (r13362) +++ trunk/abcl/contrib/jss/packages.lisp Mon Jun 27 03:23:23 2011 (r13363) @@ -14,6 +14,15 @@ #:add-to-classpath #:find-java-class #:need-to-add-directory-jar? + #:jcmn + #:japropos + +;;; Useful utilities to convert common Java items to Lisp counterparts + #:hashmap-to-hashtable + #:iterable-to-list + #:list-to-list + #:set-to-list + #:vector-to-list ;;; deprecated #:new ; use JAVA:NEW @@ -22,12 +31,6 @@ ;;; Move to JAVA? #:jclass-all-interfaces -;;; Useful utilities to convert common Java items to Lisp counterparts - #:hashmap-to-hashtable - #:iterable-to-list - #:list-to-list - #:set-to-list - #:vector-to-list ;;; Enable compatibility with jss-1.0 by placing symbols in CL-USER #:ensure-compatiblity #:*cl-user-compatibility*) From mevenson at common-lisp.net Mon Jun 27 10:23:32 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 27 Jun 2011 03:23:32 -0700 Subject: [armedbear-cvs] r13364 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Mon Jun 27 03:23:32 2011 New Revision: 13364 Log: Use java.util.regex to deal with versions more cleanly. Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Mon Jun 27 03:23:23 2011 (r13363) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Mon Jun 27 03:23:32 2011 (r13364) @@ -23,8 +23,7 @@ (handler-case (truename (read-line (sys::process-output (sys::run-program "which" `(,mvn-path))))) - ('end-of-file () - nil)))) + (end-of-file () nil)))) (when mvn (return-from find-mvn mvn))))) @@ -42,24 +41,34 @@ "Location of 'maven-core-3..

.jar', 'maven-embedder-3..

.jar' etc.") (defun mvn-version () - (let ((line - (read-line (sys::process-output (sys::run-program - (namestring (find-mvn)) '("-version"))))) - (prefix "Apache Maven ")) - - (unless (eql (search prefix line) 0) + (let* ((line + (read-line (sys::process-output + (sys::run-program + (namestring (find-mvn)) '("-version"))))) + (pattern (#"compile" + 'regex.Pattern + "Apache Maven ([0-9]+)\\.([0-9]+)\\.([0-9]+)")) + (matcher (#"matcher" pattern line)) + (found (#"find" matcher))) + (unless found (return-from mvn-version nil)) - (let ((version (subseq line (length prefix)))) - version))) + (mapcar #'parse-integer + `(,(#"group" matcher 1) + ,(#"group" matcher 2) + ,(#"group" matcher 3))))) -;;; XXX will break with release of Maven 3.1.x (defun ensure-mvn-version () "Return t if Maven version is 3.0.3 or greater." - (let ((version-string (mvn-version))) - (and (search "3.0" version-string) - (>= (parse-integer (subseq version-string - 4 (search " (" version-string))) - 3)))) + (let* ((version (mvn-version)) + (major (first version)) + (minor (second version)) + (patch (third version))) + (or + (and (>= major 3) + (>= minor 1)) + (and (>= major 3) + (>= major 0) + (>= patch 3))))) (defparameter *init* nil) From mevenson at common-lisp.net Tue Jun 28 15:28:39 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 28 Jun 2011 08:28:39 -0700 Subject: [armedbear-cvs] r13365 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jun 28 08:28:38 2011 New Revision: 13365 Log: Inform user of missing instance method name. 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 Mon Jun 27 03:23:32 2011 (r13364) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Tue Jun 28 08:28:38 2011 (r13365) @@ -45,6 +45,7 @@ import java.lang.reflect.InvocationTargetException; import java.lang.reflect.Method; import java.lang.reflect.Modifier; +import java.text.MessageFormat; import java.util.*; public final class Java @@ -861,6 +862,10 @@ methodArgs = translateMethodArguments(args, 2); method = findMethod(instance, intendedClass, methodName, methodArgs); if (method == null) { + if (intendedClass == null) { + String msg = MessageFormat.format("No instance method named {0} found for type {1}", methodName, instance.getClass().getName()); + throw new NoSuchMethodException(msg); + } String classes = intendedClass.getName(); Class actualClass = instance.getClass(); if(actualClass != intendedClass) { From mevenson at common-lisp.net Wed Jun 29 15:34:59 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 29 Jun 2011 08:34:59 -0700 Subject: [armedbear-cvs] r13366 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jun 29 08:34:58 2011 New Revision: 13366 Log: Remove deprecated use of JAVA:MAKE-IMMEDIATE-OBJECT. Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp Tue Jun 28 08:28:38 2011 (r13365) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Wed Jun 29 08:34:58 2011 (r13366) @@ -66,8 +66,7 @@ if (evenp i) do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m else - do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m))) - (null (make-immediate-object nil :ref))) + do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m)))) (loop for method across (jclass-methods interface :declared nil :public t) for method-name = (jmethod-name method) @@ -78,7 +77,7 @@ (def `(lambda ,arglist ,(when arglist '(declare (ignore ignore))) - ,(if void-p '(values) null)))) + ,(if void-p '(values) java:+null+)))) (warn "Implementing dummy method ~a for interface ~a" method-name (jclass-name interface)) (push (coerce def 'function) method-names-and-defs) From mevenson at common-lisp.net Wed Jun 29 15:35:07 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 29 Jun 2011 08:35:07 -0700 Subject: [armedbear-cvs] r13367 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Wed Jun 29 08:35:07 2011 New Revision: 13367 Log: RESOLVE-DEPENDENCIES now working for remote resolution. Something like CL-USER> (require :abcl-asdf) CL-USER> (abcl-asdf:resolve-dependencies "org.slf4j" "slf4j-api" "1.6.1") should download the required dependencies for the corresponding Maven artifact, returning the result as a string suitable for inclusion in the CLASSPATH. Abandoned strategy of using Maven Ant tasks to directly maniuplating the Aether API in contemporary version of Maven 3. Remove MVN package, folding symbols into ABCL-ASDF until clearer API vision is in place as there is no need to complicate things at this point. The ASDF links are not currently working, nor is the ability to find the Maven location under WIN32 as the resolution mechanism currently uses UNIX 'which'. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Wed Jun 29 08:34:58 2011 (r13366) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Wed Jun 29 08:35:07 2011 (r13367) @@ -1,95 +1,44 @@ (defpackage #:abcl-asdf (:use :cl) - (:export #:package)) + (:export + #:satisfy + #:as-classpath - -(defpackage #:mvn - (:use :cl) - (:export #:satisfy - #:as-classpath)) + #:resolve-artifact + #:resolve-dependencies)) (in-package :asdf) -(defclass iri (static-class) ()) +(defclass iri (static-class) + (schema authority path query fragment)) (defclass mvn (iri) ()) ;;; We interpret compilation to ensure that load-op will succeed (defmethod perform ((op compile-op) (c mvn)) (let ((version (component-version c))) - (mvn:satisfy (component-name c) - :version (if version version :latest)))) + (abcl-asdf:satisfy (component-name c) + :version (if version version :latest)))) (defmethod perform ((operation load-op) (c mvn)) (let ((version (component-version c))) (java:add-to-classpath - (mvn:as-classpath - (mvn:satisfy (component-name c) + (abcl-asdf:as-classpath + (abcl-asdf:satisfy (component-name c) :version (if version version :latest)))))) -(in-package :abcl-asdf) - -(defun decompose (iri) - (declare (ignore iri)) - ;;; XXX test - `((:scheme :jvm) - (:authority :mvn) - (:host "log4j") - (:version "1.4.10"))) - -(in-package :mvn) - -(defparameter *maven-ant-tasks.jar* - "/export/home/evenson/src/apache-maven-3.0.3/maven-ant-tasks-2.1.1.jar") - -#| - -Ant with Maven tasks would add the following - - - - -|# - -(defvar *ant-build-template* - (format nil - " - - - - - - - - - - - - - - - - - -" (symbol-name (gensym)) "junit" "junit" "3.8.2")) +(in-package #:abcl-asdf) (defun satisfy (name &key (version :latest)) - (declare (ignore name version)) - (let ((build.xml (ext:make-temp-file))) - (with-open-file (s build.xml :direction :output) - (write-string *ant-build-template* s )) - (ext:run-program - (format nil "ant -find ~A -lib ~A" - build.xml - *maven-ant-tasks.jar*)))) - -(defun as-classpath (mvn) + (declare (ignore version)) + (resolve-dependencies name)) + +(defun as-classpath (classpath) "For a given MVN entry, return a list of loadable archives suitable for addition to the classpath." - (declare (ignore mvn)) - (error "unimplemented")) - - - + (split-string classpath ":")) +(defun split-string (string split-char) + (loop :for i = 0 :then (1+ j) + :as j = (position split-char string :test #'string-equal :start i) + :collect (subseq string i j) + :while j)) \ No newline at end of file Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Wed Jun 29 08:34:58 2011 (r13366) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Wed Jun 29 08:35:07 2011 (r13367) @@ -11,11 +11,13 @@ #| Test: +(resolve-dependencies "org.slf4j" "slf4j-api" "1.6.1") -(resolve "org.slf4j" "slf4j-api" "1.6.1") +(resolve-dependencies "org.apache.maven" "maven-aether-provider" "3.0.3") |# -(defvar *mavens* '("/opt/local/bin/mvn3" "mvn3" "mvn")) +(defvar *mavens* '("/opt/local/bin/mvn3" "mvn3" "mvn" "mvn.bat") + "Locations to search for the Maven executable.") (defun find-mvn () (dolist (mvn-path *mavens*) @@ -82,37 +84,43 @@ (jss:add-directory-jars-to-class-path *mvn-libs-directory* nil) (setf *init* t)) +(defun make-wagon-provider () + (unless *init* (init)) + (java:jinterface-implementation + "org.sonatype.aether.connector.wagon.WagonProvider" + "lookup" + (lambda (role-hint) + (if (string-equal "http" role-hint) + (java:jnew "org.apache.maven.wagon.providers.http.LightweightHttpWagon") + java:+null+)) + "release" + (lambda (wagon) + (declare (ignore wagon))))) + (defun repository-system () (unless *init* (init)) (let ((locator (java:jnew "org.apache.maven.repository.internal.DefaultServiceLocator")) - (wagon-class - (java:jclass "org.sonatype.aether.connector.wagon.WagonProvider")) - (wagon-provider - (jss:find-java-class "LightweightHttpWagon")) - (repository-connector-factory-class - (java:jclass "org.sonatype.aether.connector.wagon.WagonRepositoryConnector")) + (repository-connector-factory-class + (java:jclass "org.sonatype.aether.spi.connector.RepositoryConnectorFactory")) (wagon-repository-connector-factory-class (java:jclass "org.sonatype.aether.connector.wagon.WagonRepositoryConnectorFactory")) + (wagon-provider-class + (java:jclass "org.sonatype.aether.connector.wagon.WagonProvider")) (repository-system-class (java:jclass "org.sonatype.aether.RepositorySystem"))) - (#"setService" locator wagon-class wagon-provider) - (#"addService" locator - repository-connector-factory-class + (#"addService" locator + repository-connector-factory-class wagon-repository-connector-factory-class) - (#"getService" locator repository-system-class))) - -#| -private static RepositorySystem newRepositorySystem() -{ - DefaultServiceLocator locator = new DefaultServiceLocator(); - locator.setServices( WagonProvider.class, new ManualWagonProvider() ); - locator.addService( RepositoryConnectorFactory.class, WagonRepositoryConnectorFactory.class ); - - return locator.getService( RepositorySystem.class ); -} -|# - + (#"setServices" locator + wagon-provider-class + (java:jnew-array-from-list + "org.sonatype.aether.connector.wagon.WagonProvider" + (list + (make-wagon-provider)))) + (#"getService" locator + repository-system-class))) + (defun new-session (repository-system) (let ((session (java:jnew (jss:find-java-class "MavenRepositorySystemSession"))) @@ -124,19 +132,25 @@ session (#"newLocalRepositoryManager" repository-system local-repository)))) -#| -private static RepositorySystemSession newSession( RepositorySystem system ) -{ - MavenRepositorySystemSession session = new MavenRepositorySystemSession(); - - LocalRepository localRepo = new LocalRepository( "target/local-repo" ); - session.setLocalRepositoryManager( system.newLocalRepositoryManager( localRepo ) ); - - return session; -} -|# +(defun resolve-artifact (group-id artifact-id version) + (let* ((system + (repository-system)) + (session + (new-session system)) + (repository + (jss:new "org.sonatype.aether.repository.RemoteRepository" + "central" "default" "http://repo1.maven.org/maven2/")) + (artifact-string (format nil "~A:~A:~A" + group-id artifact-id version)) + (artifact + (jss:new "org.sonatype.aether.util.artifact.DefaultArtifact" artifact-string)) + (artifact-request + (java:jnew "org.sonatype.aether.resolution.ArtifactRequest"))) + (#"setArtifact" artifact-request artifact) + (#"addRepository" artifact-request repository) + (#"resolveArtifact" system session artifact-request))) -(defun resolve (group-id artifact-id version) +(defun resolve-dependencies (group-id artifact-id version) (unless *init* (init)) (let* ((system (repository-system)) @@ -151,8 +165,7 @@ artifact "compile")) (central (java:jnew (jss:find-java-class "RemoteRepository") - "central" "default" - "http://repo1.maven.org/maven2/")) + "central" "default" "http://repo1.maven.org/maven2/")) (collect-request (java:jnew (jss:find-java-class "CollectRequest")))) (#"setRoot" collect-request dependency) (#"addRepository" collect-request central) @@ -167,30 +180,8 @@ (#"accept" node nlg) (#"getClassPath" nlg)))) -#| -public static void main( String[] args ) - throws Exception -{ - RepositorySystem repoSystem = newRepositorySystem(); - - RepositorySystemSession session = newSession( repoSystem ); - - Dependency dependency = - new Dependency( new DefaultArtifact( "org.apache.maven:maven-profile:2.2.1" ), "compile" ); - RemoteRepository central = new RemoteRepository( "central", "default", "http://repo1.maven.org/maven2/" ); - - CollectRequest collectRequest = new CollectRequest(); - collectRequest.setRoot( dependency ); - collectRequest.addRepository( central ); - DependencyNode node = repoSystem.collectDependencies( session, collectRequest ).getRoot(); - - DependencyRequest dependencyRequest = new DependencyRequest( node, null ); - - repoSystem.resolveDependencies( session, dependencyRequest ); - - PreorderNodeListGenerator nlg = new PreorderNodeListGenerator(); - node.accept( nlg ); - System.out.println( nlg.getClassPath() ); -} -|# + + + + From astalla at common-lisp.net Wed Jun 29 22:04:37 2011 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Wed, 29 Jun 2011 15:04:37 -0700 Subject: [armedbear-cvs] r13368 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Jun 29 15:04:37 2011 New Revision: 13368 Log: Better separation between java-collections and the Java FFI. java-collections should be easily moved to contrib now. Modified: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Wed Jun 29 08:35:07 2011 (r13367) +++ trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Wed Jun 29 15:04:37 2011 (r13368) @@ -4,6 +4,25 @@ (in-package :java) +(let* ((jclass (jclass "java.util.List")) + (class (%find-java-class jclass))) + (if class + (error "java.util.List is already registered as a Lisp class; since JAVA-CLASSes can't be redefined, I can't inject SEQUENCE in its class precedence list. Ensure that you require :java-collections before specializing any method on java.util.List and in general before using java.util.List as a CLOS class.") + ;;The code below is adapted from ensure-java-class in java.lisp + (%register-java-class + jclass (mop::ensure-class + (make-symbol (jclass-name jclass)) + :metaclass (find-class 'java-class) + :direct-superclasses + (let ((supers + (mapcar #'ensure-java-class + (delete nil + (concatenate 'list + (list (jclass-superclass jclass)) + (jclass-interfaces jclass)))))) + (append supers (list (find-class 'sequence)) (jclass-additional-superclasses jclass))) + :java-class jclass)))) + (defmethod print-object ((coll (jclass "java.util.Collection")) stream) (print-unreadable-object (coll stream :type t :identity t) (format stream "~A ~A" @@ -115,7 +134,7 @@ (declare (ignore s iterator)) (error "iterator-copy not supported for Java iterators.")) -;;However, it makes sense to have some sequence functions available for Sets +;;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") Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp Wed Jun 29 08:35:07 2011 (r13367) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Wed Jun 29 15:04:37 2011 (r13368) @@ -431,8 +431,6 @@ (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)