From astalla at common-lisp.net Fri Jun 4 21:50:23 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 04 Jun 2010 17:50:23 -0400 Subject: [armedbear-cvs] r12738 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jun 4 17:50:22 2010 New Revision: 12738 Log: Initial support for custom slot definition metaobjects in MOP. Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Fri Jun 4 17:50:22 2010 @@ -44,6 +44,12 @@ slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; } + public SlotDefinition(StandardClass clazz) + { + super(clazz, clazz.getClassLayout().getLength()); + slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; + } + public SlotDefinition(LispObject name, LispObject readers) { this(); @@ -113,15 +119,20 @@ return unreadableString(sb.toString()); } - // ### make-slot-definition + // ### make-slot-definition &optional class private static final Primitive MAKE_SLOT_DEFINITION = - new Primitive("make-slot-definition", PACKAGE_SYS, true, "") + new Primitive("make-slot-definition", PACKAGE_SYS, true, "&optional class") { @Override public LispObject execute() { return new SlotDefinition(); } + @Override + public LispObject execute(LispObject slotDefinitionClass) + { + return new SlotDefinition((StandardClass) slotDefinitionClass); + } }; // ### %slot-definition-name Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jun 4 17:50:22 2010 @@ -384,6 +384,11 @@ STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions()); } + public static final StandardClass DIRECT_SLOT_DEFINITION = + addStandardClass(Symbol.DIRECT_SLOT_DEFINITION, list(SLOT_DEFINITION)); + public static final StandardClass EFFECTIVE_SLOT_DEFINITION = + addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION)); + // BuiltInClass.FUNCTION is also null here (see previous comment). public static final StandardClass GENERIC_FUNCTION = addStandardClass(Symbol.GENERIC_FUNCTION, list(BuiltInClass.FUNCTION, @@ -721,6 +726,13 @@ // There are no inherited slots. SLOT_DEFINITION.setSlotDefinitions(SLOT_DEFINITION.getDirectSlotDefinitions()); + DIRECT_SLOT_DEFINITION.setCPL(DIRECT_SLOT_DEFINITION, SLOT_DEFINITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + DIRECT_SLOT_DEFINITION.finalizeClass(); + EFFECTIVE_SLOT_DEFINITION.setCPL(EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + EFFECTIVE_SLOT_DEFINITION.finalizeClass(); + // STANDARD-METHOD Debug.assertTrue(STANDARD_METHOD.isFinalized()); STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, STANDARD_OBJECT, Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jun 4 17:50:22 2010 @@ -2943,6 +2943,10 @@ PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST"); public static final Symbol STANDARD_READER_METHOD = PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); + public static final Symbol DIRECT_SLOT_DEFINITION = + PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION"); + public static final Symbol EFFECTIVE_SLOT_DEFINITION = + PACKAGE_MOP.addExternalSymbol("EFFECTIVE-SLOT-DEFINITION"); // Java interface. public static final Symbol JAVA_EXCEPTION = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jun 4 17:50:22 2010 @@ -60,6 +60,8 @@ (defconstant +the-standard-generic-function-class+ (find-class 'standard-generic-function)) (defconstant +the-T-class+ (find-class 'T)) +(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition)) +(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition)) ;; Don't use DEFVAR, because that disallows loading clos.lisp ;; after compiling it: the binding won't get assigned to T anymore @@ -259,40 +261,46 @@ (defun make-initfunction (initform) `(function (lambda () ,initform))) -(defun make-direct-slot-definition (class &key name - (initargs ()) - (initform nil) - (initfunction nil) - (readers ()) - (writers ()) - (allocation :instance) - &allow-other-keys) - (let ((slot (make-slot-definition))) - (set-slot-definition-name slot name) - (set-slot-definition-initargs slot initargs) - (set-slot-definition-initform slot initform) - (set-slot-definition-initfunction slot initfunction) - (set-slot-definition-readers slot readers) - (set-slot-definition-writers slot writers) - (set-slot-definition-allocation slot allocation) - (set-slot-definition-allocation-class slot class) - slot)) - -(defun make-effective-slot-definition (&key name - (initargs ()) - (initform nil) - (initfunction nil) - (allocation :instance) - (allocation-class nil) - &allow-other-keys) - (let ((slot (make-slot-definition))) - (set-slot-definition-name slot name) - (set-slot-definition-initargs slot initargs) - (set-slot-definition-initform slot initform) - (set-slot-definition-initfunction slot initfunction) - (set-slot-definition-allocation slot allocation) - (set-slot-definition-allocation-class slot allocation-class) - slot)) +(defun init-slot-definition (slot &key name + (initargs ()) + (initform nil) + (initfunction nil) + (readers ()) + (writers ()) + (allocation :instance) + &allow-other-keys) + (set-slot-definition-name slot name) + (set-slot-definition-initargs slot initargs) + (set-slot-definition-initform slot initform) + (set-slot-definition-initfunction slot initfunction) + (set-slot-definition-readers slot readers) + (set-slot-definition-writers slot writers) + (set-slot-definition-allocation slot allocation) + slot) + +(defun make-direct-slot-definition (class &rest args) + (let ((slot-class (direct-slot-definition-class class))) + (if (eq slot-class +the-direct-slot-definition-class+) + (let ((slot (make-slot-definition +the-direct-slot-definition-class+))) + (apply #'init-slot-definition slot args) + (set-slot-definition-allocation-class slot class) + slot) + (progn + (let ((slot (apply #'make-instance slot-class args))) + (set-slot-definition-allocation-class slot class) + slot))))) + +(defun make-effective-slot-definition (class &rest args) + (let ((slot-class (effective-slot-definition-class class))) + (if (eq slot-class +the-effective-slot-definition-class+) + (let ((slot (make-slot-definition +the-effective-slot-definition-class+))) + (apply #'init-slot-definition slot args) + (set-slot-definition-allocation-class slot class) + slot) + (progn + (let ((slot (apply #'make-instance slot-class args))) + (set-slot-definition-allocation-class slot class) + slot))))) ;;; finalize-inheritance @@ -455,10 +463,10 @@ all-names))) (defun std-compute-effective-slot-definition (class direct-slots) - (declare (ignore class)) (let ((initer (find-if-not #'null direct-slots :key #'%slot-definition-initfunction))) (make-effective-slot-definition + class :name (%slot-definition-name (car direct-slots)) :initform (if initer (%slot-definition-initform initer) @@ -559,6 +567,12 @@ :direct-default-initargs direct-default-initargs) class)) +;(defun convert-to-direct-slot-definition (class canonicalized-slot) +; (apply #'make-instance +; (apply #'direct-slot-definition-class +; class canonicalized-slot) +; canonicalized-slot)) + (defun std-after-initialization-for-classes (class &key direct-superclasses direct-slots direct-default-initargs @@ -1899,7 +1913,17 @@ (redefine-class-forwarder class-direct-default-initargs direct-default-initargs) (redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs) +(defgeneric direct-slot-definition-class (class &rest initargs)) + +(defmethod direct-slot-definition-class ((class class) &rest initargs) + (declare (ignore initargs)) + +the-direct-slot-definition-class+) + +(defgeneric effective-slot-definition-class (class &rest initargs)) +(defmethod effective-slot-definition-class ((class class) &rest initargs) + (declare (ignore initargs)) + +the-effective-slot-definition-class+) (fmakunbound 'documentation) (defgeneric documentation (x doc-type)) @@ -2212,6 +2236,17 @@ (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) (std-shared-initialize instance slot-names initargs)) +(defmethod shared-initialize ((slot slot-definition) slot-names + &rest initargs + &key name initargs initform initfunction + readers writers allocation + &allow-other-keys) + ;;Keyword args are duplicated from init-slot-definition only to have + ;;them checked. + (declare (ignore slot-names)) ;;TODO? + (declare (ignore name initargs initform initfunction readers writers allocation)) + (apply #'init-slot-definition slot initargs)) + ;;; change-class (defgeneric change-class (instance new-class &key)) From astalla at common-lisp.net Sat Jun 5 19:38:43 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sat, 05 Jun 2010 15:38:43 -0400 Subject: [armedbear-cvs] r12739 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sat Jun 5 15:38:41 2010 New Revision: 12739 Log: Removed duplicate type tests in compile-constant. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Jun 5 15:38:41 2010 @@ -2421,10 +2421,6 @@ (packagep form) (pathnamep form) (vectorp form) - (stringp form) - (packagep form) - (pathnamep form) - (vectorp form) (structure-object-p form) (standard-object-p form) (java:java-object-p form)) From astalla at common-lisp.net Sun Jun 6 22:01:49 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 06 Jun 2010 18:01:49 -0400 Subject: [armedbear-cvs] r12740 - trunk/abcl/src/org/armedbear/lisp/scripting Message-ID: Author: astalla Date: Sun Jun 6 18:01:48 2010 New Revision: 12740 Log: Removed @Override annotations that break compilation on 1.5. Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Sun Jun 6 18:01:48 2010 @@ -278,7 +278,6 @@ return new AbclScriptEngineFactory(); } - @Override public T getInterface(Class clasz) { try { return getInterface(eval("(cl:find-package '#:ABCL-SCRIPT-USER)"), clasz); @@ -288,14 +287,12 @@ } @SuppressWarnings("unchecked") - @Override public T getInterface(Object thiz, Class clasz) { Symbol s = findSymbol("jmake-proxy", "JAVA"); JavaObject iface = new JavaObject(clasz); return (T) ((JavaObject) s.execute(iface, (LispObject) thiz)).javaInstance(); } - @Override public Object invokeFunction(String name, Object... args) throws ScriptException, NoSuchMethodException { Symbol s; if(name.indexOf(':') >= 0) { @@ -320,7 +317,6 @@ } } - @Override public Object invokeMethod(Object thiz, String name, Object... args) throws ScriptException, NoSuchMethodException { throw new UnsupportedOperationException("Common Lisp does not have methods in the Java sense. Use invokeFunction instead."); } Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Sun Jun 6 18:01:48 2010 @@ -31,104 +31,92 @@ private static final AbclScriptEngine THE_ONLY_ONE_ENGINE = new AbclScriptEngine(); - @Override - public String getEngineName() { - return "ABCL Script"; - } - - @Override - public String getEngineVersion() { - return "0.1"; - } - - @Override - public List getExtensions() { - List extensions = new ArrayList(1); - extensions.add("lisp"); - return Collections.unmodifiableList(extensions); - } - - @Override - public String getLanguageName() { - return "ANSI Common Lisp"; - } - - @Override - public String getLanguageVersion() { - return "ANSI X3.226:1994"; - } - - public static String escape(String raw) { - StringBuilder sb = new StringBuilder(); - int len = raw.length(); - char c; - for(int i = 0; i < len; ++i) { - c = raw.charAt(i); - if(c != '"') { - sb.append(c); - } else { - sb.append("\\\""); - } - } - return sb.toString(); + public String getEngineName() { + return "ABCL Script"; + } + + public String getEngineVersion() { + return "0.1"; + } + + public List getExtensions() { + List extensions = new ArrayList(1); + extensions.add("lisp"); + return Collections.unmodifiableList(extensions); + } + + public String getLanguageName() { + return "ANSI Common Lisp"; + } + + public String getLanguageVersion() { + return "ANSI X3.226:1994"; + } + + public static String escape(String raw) { + StringBuilder sb = new StringBuilder(); + int len = raw.length(); + char c; + for(int i = 0; i < len; ++i) { + c = raw.charAt(i); + if(c != '"') { + sb.append(c); + } else { + sb.append("\\\""); + } } + return sb.toString(); + } - @Override - public String getMethodCallSyntax(String obj, String method, String... args) { - StringBuilder sb = new StringBuilder(); - sb.append("(jcall \""); - sb.append(method); - sb.append("\" "); - sb.append(obj); - for(String arg : args) { - sb.append(" "); - sb.append(arg); - } - sb.append(")"); - return sb.toString(); - } - - @Override - public List getMimeTypes() { - return Collections.unmodifiableList(new ArrayList()); - } - - @Override - public List getNames() { - List names = new ArrayList(1); - names.add("ABCL"); - names.add("cl"); - names.add("Lisp"); - names.add("Common Lisp"); - return Collections.unmodifiableList(names); - } - - @Override - public String getOutputStatement(String str) { - return "(cl:print \"" + str + "\")"; - } - - @Override - public Object getParameter(String key) { - // TODO Auto-generated method stub - return null; - } - - @Override - public String getProgram(String... statements) { - StringBuilder sb = new StringBuilder(); - sb.append("(cl:progn"); - for(String stmt : statements) { - sb.append("\n\t"); - sb.append(stmt); - } - sb.append(")"); - return sb.toString(); - } - - @Override - public ScriptEngine getScriptEngine() { - return THE_ONLY_ONE_ENGINE; - } + public String getMethodCallSyntax(String obj, String method, String... args) { + StringBuilder sb = new StringBuilder(); + sb.append("(jcall \""); + sb.append(method); + sb.append("\" "); + sb.append(obj); + for(String arg : args) { + sb.append(" "); + sb.append(arg); + } + sb.append(")"); + return sb.toString(); + } + + public List getMimeTypes() { + return Collections.unmodifiableList(new ArrayList()); + } + + public List getNames() { + List names = new ArrayList(1); + names.add("ABCL"); + names.add("cl"); + names.add("Lisp"); + names.add("Common Lisp"); + return Collections.unmodifiableList(names); + } + + public String getOutputStatement(String str) { + return "(cl:print \"" + str + "\")"; + } + + public Object getParameter(String key) { + // TODO Auto-generated method stub + return null; + } + + public String getProgram(String... statements) { + StringBuilder sb = new StringBuilder(); + sb.append("(cl:progn"); + for(String stmt : statements) { + sb.append("\n\t"); + sb.append(stmt); + } + sb.append(")"); + return sb.toString(); + } + + public ScriptEngine getScriptEngine() { + return THE_ONLY_ONE_ENGINE; + } } From astalla at common-lisp.net Sun Jun 6 22:02:35 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 06 Jun 2010 18:02:35 -0400 Subject: [armedbear-cvs] r12741 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Jun 6 18:02:34 2010 New Revision: 12741 Log: Fixed regression: correctly set slot-allocation-class for effective slot definitions. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 6 18:02:34 2010 @@ -262,12 +262,13 @@ `(function (lambda () ,initform))) (defun init-slot-definition (slot &key name - (initargs ()) - (initform nil) - (initfunction nil) - (readers ()) - (writers ()) - (allocation :instance) + (initargs ()) + (initform nil) + (initfunction nil) + (readers ()) + (writers ()) + (allocation :instance) + (allocation-class nil) &allow-other-keys) (set-slot-definition-name slot name) (set-slot-definition-initargs slot initargs) @@ -276,18 +277,18 @@ (set-slot-definition-readers slot readers) (set-slot-definition-writers slot writers) (set-slot-definition-allocation slot allocation) + (set-slot-definition-allocation-class slot allocation-class) slot) (defun make-direct-slot-definition (class &rest args) (let ((slot-class (direct-slot-definition-class class))) (if (eq slot-class +the-direct-slot-definition-class+) (let ((slot (make-slot-definition +the-direct-slot-definition-class+))) - (apply #'init-slot-definition slot args) - (set-slot-definition-allocation-class slot class) + (apply #'init-slot-definition slot :allocation-class class args) slot) (progn - (let ((slot (apply #'make-instance slot-class args))) - (set-slot-definition-allocation-class slot class) + (let ((slot (apply #'make-instance slot-class :allocation-class class + args))) slot))))) (defun make-effective-slot-definition (class &rest args) @@ -295,11 +296,9 @@ (if (eq slot-class +the-effective-slot-definition-class+) (let ((slot (make-slot-definition +the-effective-slot-definition-class+))) (apply #'init-slot-definition slot args) - (set-slot-definition-allocation-class slot class) slot) (progn (let ((slot (apply #'make-instance slot-class args))) - (set-slot-definition-allocation-class slot class) slot))))) ;;; finalize-inheritance From astalla at common-lisp.net Mon Jun 7 18:30:40 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 07 Jun 2010 14:30:40 -0400 Subject: [armedbear-cvs] r12742 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Jun 7 14:30:36 2010 New Revision: 12742 Log: less-reflection branch merged with trunk. verify-load temporarily disabled. Added: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java - copied, changed from r12739, /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Function.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/disassemble.lisp trunk/abcl/src/org/armedbear/lisp/gui.lisp trunk/abcl/src/org/armedbear/lisp/load.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp trunk/abcl/src/org/armedbear/lisp/proclaim.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Mon Jun 7 14:30:36 2010 @@ -97,7 +97,7 @@ symbol.setSymbolFunction(new Autoload(symbol, null, "org.armedbear.lisp.".concat(className))); } - + public void load() { if (className != null) { @@ -684,6 +684,9 @@ autoload(Symbol.COPY_LIST, "copy_list"); + autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false); + autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false); + autoload(Symbol.SET_CHAR, "StringFunctions"); autoload(Symbol.SET_SCHAR, "StringFunctions"); Copied: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (from r12739, /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java) ============================================================================== --- /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Mon Jun 7 14:30:36 2010 @@ -70,7 +70,15 @@ public byte[] getFunctionClassBytes(String name) { Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); - return readFunctionBytes(pathname); + final LispThread thread = LispThread.currentThread(); + SpecialBindingsMark mark = thread.markSpecialBindings(); + try { + //thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, NIL); + thread.bindSpecial(Symbol.LOAD_TRUENAME, NIL); + return readFunctionBytes(pathname); + } finally { + thread.resetSpecialBindings(mark); + } } public byte[] getFunctionClassBytes(Class functionClass) { Modified: trunk/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Function.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Function.java Mon Jun 7 14:30:36 2010 @@ -175,23 +175,51 @@ new JavaObject(bytes)); } + public final LispObject getClassBytes() { + LispObject o = getf(propertyList, Symbol.CLASS_BYTES, NIL); + if(o != NIL) { + return o; + } else { + ClassLoader c = getClass().getClassLoader(); + if(c instanceof FaslClassLoader) { + return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this)); + } else { + return NIL; + } + } + } + + public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes(); + public static final class pf_function_class_bytes extends Primitive { + public pf_function_class_bytes() { + super("function-class-bytes", PACKAGE_SYS, false, "function"); + } + @Override + public LispObject execute(LispObject arg) { + if (arg instanceof Function) { + return ((Function) arg).getClassBytes(); + } + return type_error(arg, Symbol.FUNCTION); + } + } + @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 0)); } @Override public LispObject execute(LispObject arg) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); } @Override public LispObject execute(LispObject first, LispObject second) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2)); } @Override @@ -199,7 +227,7 @@ LispObject third) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 3)); } @Override @@ -207,7 +235,7 @@ LispObject third, LispObject fourth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 4)); } @Override @@ -216,7 +244,7 @@ LispObject fifth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 5)); } @Override @@ -225,7 +253,7 @@ LispObject fifth, LispObject sixth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 6)); } @Override @@ -235,7 +263,7 @@ LispObject seventh) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 7)); } @Override @@ -245,7 +273,7 @@ LispObject seventh, LispObject eighth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 8)); } @Override Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Mon Jun 7 14:30:36 2010 @@ -43,8 +43,6 @@ import java.net.URL; import java.net.URLDecoder; import java.util.Hashtable; -import java.util.zip.ZipEntry; -import java.util.zip.ZipFile; public final class Lisp { @@ -1266,6 +1264,7 @@ url = Lisp.class.getResource(name.getNamestring()); input = url.openStream(); } catch (IOException e) { + System.err.println("Failed to read class bytes from boot class " + url); error(new LispError("Failed to read class bytes from boot class " + url)); } } @@ -2385,6 +2384,10 @@ public static final Symbol _LOAD_STREAM_ = internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL); + // ### *fasl-loader* + public static final Symbol _FASL_LOADER_ = + exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL); + // ### *source* // internal symbol public static final Symbol _SOURCE_ = @@ -2758,4 +2761,16 @@ Symbol.DEBUG_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true)); } + private static final SpecialOperator WITH_INLINE_CODE = new with_inline_code(); + private static class with_inline_code extends SpecialOperator { + with_inline_code() { + super("with-inline-code", PACKAGE_JVM, true, "(&optional target repr) &body body"); + } + @Override + public LispObject execute(LispObject args, Environment env) + { + return error(new SimpleError("This is a placeholder. It should only be called in compiled code, and tranformed by the compiler using special form handlers.")); + } + } + } Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Mon Jun 7 14:30:36 2010 @@ -242,6 +242,7 @@ } } + private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*"); static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_"); public static final LispObject loadSystemFile(final String filename, @@ -268,7 +269,7 @@ String path = pathname.asEntryPath(); url = Lisp.class.getResource(path); if (url == null || url.toString().endsWith("/")) { - url = Lisp.class.getResource(path + ".abcl"); + url = Lisp.class.getResource(path.replace('-', '_') + ".abcl"); if (url == null) { url = Lisp.class.getResource(path + ".lisp"); } @@ -322,6 +323,7 @@ final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL); + thread.bindSpecial(FASL_LOADER, NIL); try { Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER); return loadFileFromStream(pathname, truename, stream, @@ -567,7 +569,7 @@ thread, Stream.currentReadtable); if (obj == EOF) break; - result = eval(obj, env, thread); + result = eval(obj, env, thread); if (print) { Stream out = checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread)); Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Jun 7 14:30:36 2010 @@ -40,17 +40,33 @@ (defvar *output-file-pathname*) +(defun base-classname (&optional (output-file-pathname *output-file-pathname*)) + (sanitize-class-name (pathname-name output-file-pathname))) + +(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*)) + (%format nil "~A_0" (base-classname output-file-pathname))) + (declaim (ftype (function (t) t) compute-classfile-name)) (defun compute-classfile-name (n &optional (output-file-pathname *output-file-pathname*)) "Computes the name of the class file associated with number `n'." (let ((name - (%format nil "~A-~D" - (substitute #\_ #\. - (pathname-name output-file-pathname)) n))) + (sanitize-class-name + (%format nil "~A_~D" (pathname-name output-file-pathname) n)))) (namestring (merge-pathnames (make-pathname :name name :type "cls") output-file-pathname)))) +(defun sanitize-class-name (name) + (let ((name (copy-seq name))) + (dotimes (i (length name)) + (declare (type fixnum i)) + (when (or (char= (char name i) #\-) + (char= (char name i) #\.) + (char= (char name i) #\Space)) + (setf (char name i) #\_))) + name)) + + (declaim (ftype (function () t) next-classfile-name)) (defun next-classfile-name () (compute-classfile-name (incf *class-number*))) @@ -69,12 +85,14 @@ (declaim (ftype (function (t) t) verify-load)) (defun verify-load (classfile) - (if (> *safety* 0) - (and classfile + #|(if (> *safety* 0) + (and classfile (let ((*load-truename* *output-file-pathname*)) (report-error (load-compiled-function classfile)))) - t)) + t)|# + (declare (ignore classfile)) + t) (declaim (ftype (function (t) t) process-defconstant)) (defun process-defconstant (form) @@ -144,6 +162,7 @@ (parse-body body) (let* ((expr `(lambda ,lambda-list , at decls (block ,block-name , at body))) + (saved-class-number *class-number*) (classfile (next-classfile-name)) (internal-compiler-errors nil) (result (with-open-file @@ -168,7 +187,8 @@ compiled-function) (setf form `(fset ',name - (proxy-preloaded-function ',name ,(file-namestring classfile)) + (sys::get-fasl-function *fasl-loader* + ,saved-class-number) ,*source-position* ',lambda-list ,doc)) @@ -225,6 +245,7 @@ (let ((name (second form))) (eval form) (let* ((expr (function-lambda-expression (macro-function name))) + (saved-class-number *class-number*) (classfile (next-classfile-name))) (with-open-file (f classfile @@ -241,14 +262,10 @@ (if (special-operator-p name) `(put ',name 'macroexpand-macro (make-macro ',name - (proxy-preloaded-function - '(macro-function ,name) - ,(file-namestring classfile)))) + (sys::get-fasl-function *fasl-loader* ,saved-class-number))) `(fset ',name (make-macro ',name - (proxy-preloaded-function - '(macro-function ,name) - ,(file-namestring classfile))) + (sys::get-fasl-function *fasl-loader* ,saved-class-number)) ,*source-position* ',(third form))))))))) (DEFTYPE @@ -348,8 +365,12 @@ ;; to load the compiled functions. Note that this trickery ;; was already used in verify-load before I used it, ;; however, binding *load-truename* isn't fully compliant, I think. - (let ((*load-truename* *output-file-pathname*)) - (when compile-time-too + (when compile-time-too + (let ((*load-truename* *output-file-pathname*) + (*fasl-loader* (make-fasl-class-loader + *class-number* + (concatenate 'string "org.armedbear.lisp." (base-classname)) + nil))) (eval form)))) (declaim (ftype (function (t) t) convert-ensure-method)) @@ -366,7 +387,8 @@ (eq (%car function-form) 'FUNCTION)) (let ((lambda-expression (cadr function-form))) (jvm::with-saved-compiler-policy - (let* ((classfile (next-classfile-name)) + (let* ((saved-class-number *class-number*) + (classfile (next-classfile-name)) (result (with-open-file (f classfile @@ -379,7 +401,8 @@ (declare (ignore result)) (cond (compiled-function (setf (getf tail key) - `(load-compiled-function ,(file-namestring classfile)))) + `(sys::get-fasl-function *fasl-loader* ,saved-class-number))) +;; `(load-compiled-function ,(file-namestring classfile)))) (t ;; FIXME This should be a warning or error of some sort... (format *error-output* "; Unable to compile method~%"))))))))) @@ -412,6 +435,7 @@ (return-from convert-toplevel-form (precompiler:precompile-form form nil *compile-file-environment*))) (let* ((expr `(lambda () ,form)) + (saved-class-number *class-number*) (classfile (next-classfile-name)) (result (with-open-file @@ -425,7 +449,7 @@ (declare (ignore result)) (setf form (if compiled-function - `(funcall (load-compiled-function ,(file-namestring classfile))) + `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number)) (precompiler:precompile-form form nil *compile-file-environment*))))) @@ -572,25 +596,22 @@ (write (list 'setq '*source* *compile-file-truename*) :stream out) (%stream-terpri out) - ;; Note: Beyond this point, you can't use DUMP-FORM, - ;; because the list of uninterned symbols has been fixed now. - (when *fasl-uninterned-symbols* - (write (list 'setq '*fasl-uninterned-symbols* - (coerce (mapcar #'car - (nreverse *fasl-uninterned-symbols*)) - 'vector)) - :stream out)) - (%stream-terpri out) - ;; we work with a fixed variable name here to work around the - ;; lack of availability of the circle reader in the fasl reader - ;; but it's a toplevel form anyway - (write `(dotimes (i ,*class-number*) - (function-preload - (%format nil "~A-~D.cls" - ,(substitute #\_ #\. (pathname-name output-file)) - (1+ i)))) - :stream out - :circle t) + ;; Note: Beyond this point, you can't use DUMP-FORM, + ;; because the list of uninterned symbols has been fixed now. + (when *fasl-uninterned-symbols* + (write (list 'setq '*fasl-uninterned-symbols* + (coerce (mapcar #'car + (nreverse *fasl-uninterned-symbols*)) + 'vector)) + :stream out)) + (%stream-terpri out) + + (when (> *class-number* 0) + (generate-loader-function) + (write (list 'setq '*fasl-loader* + `(sys::make-fasl-class-loader + ,*class-number* + ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) (%stream-terpri out)) @@ -609,7 +630,11 @@ (zipfile (namestring (merge-pathnames (make-pathname :type type) output-file))) - (pathnames ())) + (pathnames nil) + (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls") + output-file)))) + (when (probe-file fasl-loader) + (push fasl-loader pathnames)) (dotimes (i *class-number*) (let* ((pathname (compute-classfile-name (1+ i)))) (when (probe-file pathname) @@ -632,6 +657,55 @@ (namestring output-file) elapsed)))) (values (truename output-file) warnings-p failure-p))) +(defmacro ncase (expr min max &rest clauses) + "A CASE where all test clauses are numbers ranging from a minimum to a maximum." + ;;Expr is subject to multiple evaluation, but since we only use ncase for + ;;fn-index below, let's ignore it. + (let* ((half (floor (/ (- max min) 2))) + (middle (+ min half))) + (if (> (- max min) 10) + `(if (< ,expr ,middle) + (ncase ,expr ,min ,middle ,@(subseq clauses 0 half)) + (ncase ,expr ,middle ,max ,@(subseq clauses half))) + `(case ,expr , at clauses)))) + +(defun generate-loader-function () + (let* ((basename (base-classname)) + (expr `(lambda (fasl-loader fn-index) + (identity fasl-loader) ;;to avoid unused arg + (ncase fn-index 0 ,(1- *class-number*) + ,@(loop + :for i :from 1 :to *class-number* + :collect + (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i))) + `(,(1- i) + (jvm::with-inline-code () + (jvm::emit 'jvm::aload 1) + (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" + nil jvm::+java-object+) + (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") + (jvm::emit 'jvm::dup) + (jvm::emit-push-constant-int ,(1- i)) + (jvm::emit 'jvm::new ,class) + (jvm::emit 'jvm::dup) + (jvm::emit-invokespecial-init ,class '()) + (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction" + (list "I" jvm::+lisp-object+) jvm::+lisp-object+) + (jvm::emit 'jvm::pop)) + t)))))) + (classname (fasl-loader-classname)) + (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") + *output-file-pathname*)))) + (jvm::with-saved-compiler-policy + (jvm::with-file-compilation + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (jvm:compile-defun nil expr nil + classfile f nil)))))) + (defun compile-file-if-needed (input-file &rest allargs &key force-compile &allow-other-keys) (setf input-file (truename input-file)) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Mon Jun 7 14:30:36 2010 @@ -1298,7 +1298,7 @@ (format t "; inlining call to local function ~S~%" op))) (return-from p1-function-call (let ((*inline-declarations* - (remove op *inline-declarations* :key #'car))) + (remove op *inline-declarations* :key #'car :test #'equal))) (p1 expansion)))))) ;; FIXME @@ -1432,7 +1432,8 @@ (TRULY-THE p1-truly-the) (UNWIND-PROTECT p1-unwind-protect) (THREADS:SYNCHRONIZED-ON - p1-threads-synchronized-on))) + p1-threads-synchronized-on) + (JVM::WITH-INLINE-CODE identity))) (install-p1-handler (%car pair) (%cadr pair)))) (initialize-p1-handlers) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Jun 7 14:30:36 2010 @@ -198,6 +198,8 @@ (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF)) n))) +(defconstant +fasl-loader-class+ + "org/armedbear/lisp/FaslClassLoader") (defconstant +java-string+ "Ljava/lang/String;") (defconstant +java-object+ "Ljava/lang/Object;") (defconstant +lisp-class+ "org/armedbear/lisp/Lisp") @@ -2267,12 +2269,22 @@ local-function *declared-functions* ht g (setf g (symbol-name (gensym "LFUN"))) (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function))) + (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname))) (*code* *static-code*)) ;; fixme *declare-inline* - (declare-field g +lisp-object+ +field-access-default+) - (emit 'ldc (pool-string (file-namestring pathname))) - (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" - (list +java-string+) +lisp-object+) + (declare-field g +lisp-object+ +field-access-private+) + (emit 'new class-name) + (emit 'dup) + (emit-invokespecial-init class-name '()) + + ;(emit 'ldc (pool-string (pathname-name pathname))) + ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction" + ;(list +java-string+) +lisp-object+) + +; (emit 'ldc (pool-string (file-namestring pathname))) + +; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" +; (list +java-string+) +lisp-object+) (emit 'putstatic *this-class* g +lisp-object+) (setf *static-code* *code*) (setf (gethash local-function ht) g)))) @@ -5094,7 +5106,8 @@ (local-function-function local-function))))) (emit 'getstatic *this-class* g +lisp-object+))))) ; Stack: template-function - ((member name *functions-defined-in-current-file* :test #'equal) + ((and (member name *functions-defined-in-current-file* :test #'equal) + (not (notinline-p name))) (emit 'getstatic *this-class* (declare-setf-function name) +lisp-object+) (emit-move-from-stack target)) @@ -7544,6 +7557,32 @@ ;; delay resolving the method to run-time; it's unavailable now (compile-function-call form target representation)))) +#|(defknown p2-java-jcall (t t t) t) +(define-inlined-function p2-java-jcall (form target representation) + ((and (> *speed* *safety*) + (< 1 (length form)) + (eq 'jmethod (car (cadr form))) + (every #'stringp (cdr (cadr form))))) + (let ((m (ignore-errors (eval (cadr form))))) + (if m + (let ((must-clear-values nil) + (arg-types (raw-arg-types (jmethod-params m)))) + (declare (type boolean must-clear-values)) + (dolist (arg (cddr form)) + (compile-form arg 'stack nil) + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t)))) + (when must-clear-values + (emit-clear-values)) + (dotimes (i (jarray-length raw-arg-types)) + (push (jarray-ref raw-arg-types i) arg-types)) + (emit-invokevirtual (jclass-name (jmethod-declaring-class m)) + (jmethod-name m) + (nreverse arg-types) + (jmethod-return-type m))) + ;; delay resolving the method to run-time; it's unavailable now + (compile-function-call form target representation))))|# (defknown p2-char= (t t t) t) (defun p2-char= (form target representation) @@ -8220,6 +8259,13 @@ (setf (method-handlers execute-method) (nreverse *handlers*))) t) +(defun p2-with-inline-code (form target representation) + ;;form = (with-inline-code (&optional target-var repr-var) ...body...) + (destructuring-bind (&optional target-var repr-var) (cadr form) + (eval `(let (,@(when target-var `((,target-var ,target))) + ,@(when repr-var `((,repr-var ,representation)))) + ,@(cddr form))))) + (defun compile-1 (compiland stream) (let ((*all-variables* nil) (*closure-variables* nil) @@ -8512,6 +8558,7 @@ (install-p2-handler 'java:jclass 'p2-java-jclass) (install-p2-handler 'java:jconstructor 'p2-java-jconstructor) (install-p2-handler 'java:jmethod 'p2-java-jmethod) +; (install-p2-handler 'java:jcall 'p2-java-jcall) (install-p2-handler 'char= 'p2-char=) (install-p2-handler 'characterp 'p2-characterp) (install-p2-handler 'coerce-to-function 'p2-coerce-to-function) @@ -8596,6 +8643,7 @@ (install-p2-handler 'vector-push-extend 'p2-vector-push-extend) (install-p2-handler 'write-8-bits 'p2-write-8-bits) (install-p2-handler 'zerop 'p2-zerop) + (install-p2-handler 'with-inline-code 'p2-with-inline-code) t) (initialize-p2-handlers) Modified: trunk/abcl/src/org/armedbear/lisp/disassemble.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/disassemble.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/disassemble.lisp Mon Jun 7 14:30:36 2010 @@ -47,14 +47,15 @@ (when (functionp function) (unless (compiled-function-p function) (setf function (compile nil function))) - (when (getf (function-plist function) 'class-bytes) - (with-input-from-string - (stream (disassemble-class-bytes (getf (function-plist function) 'class-bytes))) - (loop - (let ((line (read-line stream nil))) - (unless line (return)) - (write-string "; ") - (write-string line) - (terpri)))) - (return-from disassemble))) - (%format t "; Disassembly is not available.~%"))) + (let ((class-bytes (function-class-bytes function))) + (when class-bytes + (with-input-from-string + (stream (disassemble-class-bytes class-bytes)) + (loop + (let ((line (read-line stream nil))) + (unless line (return)) + (write-string "; ") + (write-string line) + (terpri)))) + (return-from disassemble))) + (%format t "; Disassembly is not available.~%")))) Modified: trunk/abcl/src/org/armedbear/lisp/gui.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gui.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/gui.lisp Mon Jun 7 14:30:36 2010 @@ -1,5 +1,7 @@ (in-package :extensions) +(require :java) + (defvar *gui-backend* :swing) (defun init-gui () Modified: trunk/abcl/src/org/armedbear/lisp/load.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/load.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/load.lisp Mon Jun 7 14:30:36 2010 @@ -38,10 +38,11 @@ (if-does-not-exist t) (external-format :default)) (declare (ignore external-format)) ; FIXME - (%load (if (streamp filespec) - filespec - (merge-pathnames (pathname filespec))) - verbose print if-does-not-exist)) + (let (*fasl-loader*) + (%load (if (streamp filespec) + filespec + (merge-pathnames (pathname filespec))) + verbose print if-does-not-exist))) (defun load-returning-last-result (filespec &key @@ -50,7 +51,8 @@ (if-does-not-exist t) (external-format :default)) (declare (ignore external-format)) ; FIXME - (%load-returning-last-result (if (streamp filespec) - filespec - (merge-pathnames (pathname filespec))) - verbose print if-does-not-exist)) \ No newline at end of file + (let (*fasl-loader*) + (%load-returning-last-result (if (streamp filespec) + filespec + (merge-pathnames (pathname filespec))) + verbose print if-does-not-exist))) \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Mon Jun 7 14:30:36 2010 @@ -32,13 +32,10 @@ (in-package "SYSTEM") -(export '(*inline-declarations* - process-optimization-declarations +(export '(process-optimization-declarations inline-p notinline-p inline-expansion expand-inline *defined-functions* *undefined-functions* note-name-defined)) -(defvar *inline-declarations* nil) - (declaim (ftype (function (t) t) process-optimization-declarations)) (defun process-optimization-declarations (forms) (dolist (form forms) @@ -86,7 +83,7 @@ (declaim (ftype (function (t) t) inline-p)) (defun inline-p (name) (declare (optimize speed)) - (let ((entry (assoc name *inline-declarations*))) + (let ((entry (assoc name *inline-declarations* :test #'equal))) (if entry (eq (cdr entry) 'INLINE) (and (symbolp name) (eq (get name '%inline) 'INLINE))))) @@ -94,7 +91,7 @@ (declaim (ftype (function (t) t) notinline-p)) (defun notinline-p (name) (declare (optimize speed)) - (let ((entry (assoc name *inline-declarations*))) + (let ((entry (assoc name *inline-declarations* :test #'equal))) (if entry (eq (cdr entry) 'NOTINLINE) (and (symbolp name) (eq (get name '%inline) 'NOTINLINE))))) @@ -961,7 +958,8 @@ (symbol-name symbol)) 'precompiler)))) (unless (and handler (fboundp handler)) - (error "No handler for ~S." symbol)) + (error "No handler for ~S." (let ((*package* (find-package :keyword))) + (format nil "~S" symbol)))) (setf (get symbol 'precompile-handler) handler))) (defun install-handlers () @@ -1024,7 +1022,9 @@ (TRULY-THE precompile-truly-the) (THREADS:SYNCHRONIZED-ON - precompile-threads-synchronized-on))) + precompile-threads-synchronized-on) + + (JVM::WITH-INLINE-CODE precompile-identity))) (install-handler (first pair) (second pair)))) (install-handlers) Modified: trunk/abcl/src/org/armedbear/lisp/proclaim.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/proclaim.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/proclaim.lisp Mon Jun 7 14:30:36 2010 @@ -31,7 +31,7 @@ (in-package #:system) -(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type)) +(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type *inline-declarations*)) (defmacro declaim (&rest decls) `(eval-when (:compile-toplevel :load-toplevel :execute) @@ -43,6 +43,7 @@ :format-control "The symbol ~S cannot be both the name of a type and the name of a declaration." :format-arguments (list name))) +(defvar *inline-declarations* nil) (defvar *declaration-types* (make-hash-table :test 'eq)) ;; "A symbol cannot be both the name of a type and the name of a declaration. @@ -91,8 +92,9 @@ (apply 'proclaim-type (cdr declaration-specifier))) ((INLINE NOTINLINE) (dolist (name (cdr declaration-specifier)) - (when (symbolp name) ; FIXME Need to support non-symbol function names. - (setf (get name '%inline) (car declaration-specifier))))) + (if (symbolp name) + (setf (get name '%inline) (car declaration-specifier)) + (push (cons name (car declaration-specifier)) *inline-declarations*)))) (DECLARATION (dolist (name (cdr declaration-specifier)) (when (or (get name 'deftype-definition) From ehuelsmann at common-lisp.net Mon Jun 7 20:32:59 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 07 Jun 2010 16:32:59 -0400 Subject: [armedbear-cvs] r12743 - public_html Message-ID: Author: ehuelsmann Date: Mon Jun 7 16:32:57 2010 New Revision: 12743 Log: Fix link to examples in our repository. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Mon Jun 7 16:32:57 2010 @@ -99,7 +99,7 @@
  • FAQ
  • Introduction: building & running
  • Documentation
    • -
  • Examples
    • +
  • Examples
  • Testimonials
  • Bug reporting
    • From ehuelsmann at common-lisp.net Mon Jun 7 20:34:26 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 07 Jun 2010 16:34:26 -0400 Subject: [armedbear-cvs] r12744 - public_html Message-ID: Author: ehuelsmann Date: Mon Jun 7 16:34:24 2010 New Revision: 12744 Log: Don't delete the wrong 'abcl/'. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Mon Jun 7 16:34:24 2010 @@ -99,7 +99,7 @@
  • FAQ
  • Introduction: building & running
  • Documentation
    • -
  • Examples
    • +
  • Examples
  • Testimonials
  • Bug reporting
    • From ehuelsmann at common-lisp.net Mon Jun 7 20:48:26 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 07 Jun 2010 16:48:26 -0400 Subject: [armedbear-cvs] r12745 - public_html Message-ID: Author: ehuelsmann Date: Mon Jun 7 16:48:24 2010 New Revision: 12745 Log: Replace an undated testimonial with a dated one. Note: We should probably work toward more dated testimonials, just for the credibility of them. Modified: public_html/testimonials.shtml Modified: public_html/testimonials.shtml ============================================================================== --- public_html/testimonials.shtml (original) +++ public_html/testimonials.shtml Mon Jun 7 16:48:24 2010 @@ -29,6 +29,18 @@

    Testimonials

    +
    David Kirkman (Astronomer at University of California, San Diego) + - June 7, 2010
    +
    +"I've been using ABCL to help position the Keck telescope on targets +that are too faint to see with the slit guider. I used code I +created in 1994 - in Lisp - for the exact calculations and combined it +with Java libraries for getting images in and displaying things. The +Lisp code ran unmodified. And what's more: I can run it all on my +Windows laptop!

    +The original project went so well that I stared to do new work in Lisp again." +
    +
    Brad Garton (Columbia University Computer Music Center)
    @@ -87,29 +99,6 @@
    I am in the process of integrating ABCL with MathRider in preparation for when Maxima is able to run on it.
    -
    Alex Mizhari -
    -
    - -I'm using ABCL for various web projects since aproximately 2004. None of them have gone public (so far), so i can't give a link. -I released sort of framework for building web apps with ABCL was released into -open source: abcl-web. -Another thing probably worth mentioning -- bindings to Jena2 RDF/SPARQL library: -http://abcl-web.sourceforge.net/rdf.html (it's sort of incomplete but usable, i think). -
    -What i like in ABCL is that it has reasonably stable multithreading, does -not crash unpredictably (unlike some other implementations) and can be -fixed in more-or-less easy way if something goes bad, and access to Java -libs, of course. I had some problems with it, though, to name some: -
      -
    • SLIME being botched (i suspect due to CLOS invoking compiler which is not -reentrant),
      • -
    • CLOS not thread safe,
      • -
    • compiler producing wrong code.
      • -
    -That certainly made experience with ABCL less pleasant that it could be, -but in general it was more-or-less good. -
    From ehuelsmann at common-lisp.net Mon Jun 7 20:55:09 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 07 Jun 2010 16:55:09 -0400 Subject: [armedbear-cvs] r12746 - in public_html: . doc Message-ID: Author: ehuelsmann Date: Mon Jun 7 16:55:07 2010 New Revision: 12746 Log: Add documentation contribution by Paul Reiners. Submitted by: Paul Reiners (paul dot reiners at gmail dot com) Added: public_html/doc/abcl-user.html Modified: public_html/index.shtml Added: public_html/doc/abcl-user.html ============================================================================== --- (empty file) +++ public_html/doc/abcl-user.html Mon Jun 7 16:55:07 2010 @@ -0,0 +1,221 @@ + + + +Armed Bear Common Lisp User Documentation + + + +
    +

    Armed Bear Common Lisp (ABCL) - User Documentation

    +

    "It's the right to arm bears" ?Paul Westerberg

    +
    +

    Overview

    +
      +
    • Supports interoperability both ways between Java and Lisp.
      • +
    • ABCL is distributed under the GNU General Public License with Classpath exception. +
        +
      • Basically this means you can use ABCL from your application without the need to make your own application open source. +
        • +
      +
      • +
    +

    Benefits of using ABCL

    +
      +
    • Java has great GUI libraries,
      + <religious-statement>
      +      but it's not the world's greatest programming language
      + </religious-statement>.
      • +
    • <religious-statement>
      +     Lisp is the world's greatest programming language
      + </religious-statement>,
      + but has no standard GUI libraries.
      • +
    • Therefore: Write great applications using Java for your front-end GUI backed with Lisp code and get the best of both worlds.
      • +
    +

    Installing ABCL

    +
      +
    • Go to the ABCL page and find the download link.
      • +
    • Download the Zip of the Latest Build.
      • +
    • Upzip the files.
      • +
    • Build according to instructions here.
      • +
    • In the end, you will end up with a file called
      +      <abcl-dir>\dist\abcl.jar
      • +
    • You will need to add abcl.jar to your class path for ABCL projects.
      • +
    • That's it!
      • +
    +

    Hello, world!

    +
      +
    • Type the following at the command line (adjust the path as necessary): + 
           C:\abcl-src-0.15.0>cd dist
+     C:\abcl-src-0.15.0\dist>java -jar abcl.jar
+
      + This will run the Lisp REPL.
      • +
    • At the REPL prompt, type: + 
           CL-USER(1): (format t "Hello, world!")
+     Hello, world!
+     NIL
+
      +
      • +
    • To exit the REPL, type: + 
           CL-USER(2): (exit)
+
      +
      • +
    +

    ABCL Cons and LispObject classes

    +
      +
    • Cons +
        +
      • Corresponds to a Lisp cons or list
        • +
      • Has car() and cdr() methods if you want to write Java code in a Lisp style.
        • +
      • Can also unbox Cons objects into arrays, if you wish by using the copyToArray() method which returns LispObject[].
        • +
      +
      • +
    • LispObject +
        +
      • A Lisp S-expression
        • +
      • Can unbox LispObjects to Java primitives with methods such as intValue() which returns (surprise!) an int.
        • +
      +
      • +
    +

    Other important ABCL classes

    +All the classes below are in the org.armedbear.lisp package: +
      +
    • Interpreter +
        +
      • createInstance(): Creates a Lisp interpreter.
        • +
      • eval(String expression): Evaluates a Lisp expression. Often used with load to load a Lisp file.
        • +
      +
      • +
    • Packages +
        +
      • findPackage(String packageName): Finds a Lisp package.
        • +
      +
      • +
    • Package +
        +
      • findAccessibleSymbol(String symbolName): Finds a symbol such as that for a function.
        • +
      +
      • +
    • Symbol +
        +
      • getSymbolFunction(): Returns the function for a corresponding symbol.
        • +
      +
      • +
    • Function +
        +
      • execute(): Executes a function taking a variable number of LispObjects as arguments.
        • +
      +
      • +
    • JavaObject: A subclass of LispObject for objects coming from Java.
      • +
    +

    Getting a Lisp package from Java

    +
      +
    • To load a file of Lisp functions from Java, you do the following: + 
           Interpreter interpreter = Interpreter.createInstance();
+     interpreter.eval("(load \"my-lisp-code.lisp\")");
+
      +
      • +
    • You can then load the package containing a function you want to call.  In this case, our function is in the default Lisp package: + 
           Package defaultPackage = 
+          Packages.findPackage("CL-USER");
+
      +
      • +
    +

    Getting a Lisp function from Java

    +
      +
    • Suppose we have a function called my-function defined in my-lisp-code.lisp (which was loaded above). We obtain it in two steps like this: + 
           Symbol myFunctionSym =
+          defaultPackage.findAccessibleSymbol(
+               "MY-FUNCTION");
+     Function myFunction =
+          myFunctionSym.getSymbolFunction();
      • +
    +

    Calling a Lisp function from Java

    +
      +
    • Call a Lisp function like this: + 
           Cons list = 
+          (Cons) myFunction.execute(
+                        Fixnum.getInstance(64),
+                        Fixnum.getInstance(64));
+
      +
      • +
    • Our original Lisp function returned a list.  ABCL's Cons Java class corresponds to a Lisp list.  Note also that we wrap the ints (in this example) as Fixnums.
      • +
    • On the Lisp side, we can access these integers as if they came from directly from another Lisp method: + 
           (defun my-function (n1 n2)
+               ...)
+
      +
      • +
    +

    Converting Java objects to Lisp values and vice-versa

    +

    Since the user can't be expected to know how to map every Java type to Lisp and vice-versa, there are a couple
    + of nice methods you can use in all cases:

    +
      +
    • public static LispObject JavaObject.getInstance(Object, boolean): Converts (or wraps) a Java object to a Lisp object, if the boolean is true (else it just wraps it in a JavaObject).
      • +
    • public Object LispObject.javaInstance(): Converts (or unwraps) a Lisp object to Java. You can invoke this on any Lisp object; if it can't be converted, it will be returned as-is.
      • +
    +

    +Calling Java from Lisp +

    +

    This code sample is by Ville Voutilainen.

    +

    Java code

    + 
    public class Main {
+    public int addTwoNumbers(int a, int b) {
+        return a + b;
+    }
+}
+
    + See the entire code sample here. +

    Lisp code

    +

    +We need to get the +

    +
      +
    1. +class (Main) +
      2. +
    2. +classes of the parameters (int) +
      3. +
    3. +method reference (getting that requires the class of our object and the classes of the parameters) +
      4. +
    +

    +After that we can invoke the function with jcall, +giving the method reference, the object and the parameters. +The result is a Lisp object (no need to do jobject-lisp-value, +unless we invoke the method +with jcall-raw). +

    +
    (defun void-function (param)
+  (let* ((class (jclass "Main"))
+         (intclass (jclass "int"))
+         (method (jmethod class "addTwoNumbers" intclass intclass))
+         (result (jcall method param 2 4)))
+    (format t "in void-function, result of calling addTwoNumbers(2, 4): ~a~%" result)))
+
    + See the entire code sample here. +

    Sample Code

    +
      +
    • + Code examples can be found here. +
      • +
    • Conway's Game of Life: This example shows how to call Lisp code from Java. +
        +
      • life.lisp: Lisp code for simulating Conway's Game of Life cellular automaton.
        • +
      • LifeGUI.java: A subclass of JApplet for showing a Life universe.  Calls life.lisp for all Life functionality.
        • +
      +
      • +
    +

    References

    + +
    +

    This documentation was written by Paul Reiners (except where otherwise noted). Helpful suggestions and corrections were given by Alessio Stalla and others on the ABCL mailing list. Please email me with any suggestions or corrections.

    +
    +Creative Commons License
    Armed Bear Common Lisp Tutorial by Paul Reiners is licensed under a Creative Commons Attribution-Noncommercial-Share Alike 3.0 United States License. Code samples are released under the GNU General Public License. + + + \ No newline at end of file Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Mon Jun 7 16:55:07 2010 @@ -98,7 +98,7 @@
    • FAQ
    • Introduction: building & running
      • -
    • Documentation
      • +
    • Documentation
    • Examples
    • Testimonials
    • Bug reporting
      • From ehuelsmann at common-lisp.net Mon Jun 7 20:56:01 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 07 Jun 2010 16:56:01 -0400 Subject: [armedbear-cvs] r12747 - public_html Message-ID: Author: ehuelsmann Date: Mon Jun 7 16:56:00 2010 New Revision: 12747 Log: Since everything needs two commits tonight. Here's the second one. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Mon Jun 7 16:56:00 2010 @@ -98,7 +98,7 @@
      • FAQ
      • Introduction: building & running
        • -
      • Documentation
        • +
      • Documentation
      • Examples
      • Testimonials
      • Bug reporting
        • From mevenson at common-lisp.net Wed Jun 9 11:17:18 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 09 Jun 2010 07:17:18 -0400 Subject: [armedbear-cvs] r12748 - in trunk/abcl: . examples examples/google-app-engine examples/gui examples/java-exception examples/java-interface examples/java-to-lisp-1 examples/java-to-lisp-2 examples/jsr-223 examples/lisp-to-java examples/misc nbproject src/org/armedbear/lisp src/org/armedbear/lisp/java src/org/armedbear/lisp/java/swing src/org/armedbear/lisp/scripting Message-ID: Author: mevenson Date: Wed Jun 9 07:17:17 2010 New Revision: 12748 Log: Include 'examples' in release source distribution. Reported by Mario Lang. Added: trunk/abcl/examples/.abclrc - copied unchanged from r12742, /trunk/abcl/examples/misc/dotabclrc trunk/abcl/examples/complete.lisp trunk/abcl/examples/hello.java - copied unchanged from r12742, /trunk/abcl/examples/misc/hello.java trunk/abcl/examples/init.lisp trunk/abcl/examples/key-pressed.lisp trunk/abcl/examples/update-check-enabled.lisp - copied unchanged from r12742, /trunk/abcl/examples/misc/update-check-enabled.lisp trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java - copied, changed from r12742, /trunk/abcl/examples/gui/abcl/DialogPromptStream.java trunk/abcl/src/org/armedbear/lisp/java/swing/SwingDialogPromptStream.java - copied, changed from r12742, /trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java Removed: trunk/abcl/examples/README trunk/abcl/examples/google-app-engine/ trunk/abcl/examples/gui/ trunk/abcl/examples/java-exception/ trunk/abcl/examples/java-interface/ trunk/abcl/examples/java-to-lisp-1/ trunk/abcl/examples/java-to-lisp-2/ trunk/abcl/examples/jsr-223/ trunk/abcl/examples/lisp-to-java/ trunk/abcl/examples/misc/ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java Modified: trunk/abcl/build.xml trunk/abcl/nbproject/build-impl.xml trunk/abcl/nbproject/genfiles.properties trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Function.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Readtable.java trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/disassemble.lisp trunk/abcl/src/org/armedbear/lisp/gui.lisp trunk/abcl/src/org/armedbear/lisp/load.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp trunk/abcl/src/org/armedbear/lisp/proclaim.lisp trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Wed Jun 9 07:17:17 2010 @@ -464,6 +464,8 @@ + + Added: trunk/abcl/examples/complete.lisp ============================================================================== --- (empty file) +++ trunk/abcl/examples/complete.lisp Wed Jun 9 07:17:17 2010 @@ -0,0 +1,88 @@ +;;; complete.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: complete.lisp,v 1.2 2004-09-05 00:12:25 piso Exp $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(in-package "J") + +(export 'complete) + +(defvar *prefix* nil) +(defvar *completions* ()) +(defvar *completion-index* 0) + +(defun compound-prefix-match (prefix target) + (let ((tlen (length target)) + (tpos 0)) + (dotimes (i (length prefix)) + (when (>= tpos tlen) + (return-from compound-prefix-match nil)) + (let ((ch (schar prefix i))) + (if (char= ch #\-) + (unless (setf tpos (position #\- target :start tpos)) + (return-from compound-prefix-match nil)) + (unless (char-equal ch (schar target tpos)) + (return-from compound-prefix-match nil))) + (incf tpos))) + t)) + +(defun completion-set (prefix) + (let ((result ())) + (do-external-symbols (symbol "CL") + (let ((name (symbol-name symbol))) + (when (compound-prefix-match prefix name) + (push symbol result)))) + result)) + +(defun completion-prefix () + (let* ((string (line-chars (current-line))) + (end (mark-charpos (current-point)))) + (do ((start (1- end) (1- start))) + ((< start 0) (subseq string 0 end)) + (let ((ch (schar string start))) + (when (or (eql ch #\space) (eql ch #\()) + (incf start) + (return-from completion-prefix (subseq string start end))))))) + +(defun complete () + (cond ((eq *last-command* 'complete) + (unless (> (length *completions*) 1) + (return-from complete)) + (undo) + (incf *completion-index*) + (when (> *completion-index* (1- (length *completions*))) + (setf *completion-index* 0))) + (t + (setf *prefix* (completion-prefix) + *completions* nil + *completion-index* 0) + (when *prefix* + (setf *completions* (completion-set *prefix*))))) + (when *completions* + (let ((completion (string-downcase (nth *completion-index* *completions*))) + (point (current-point))) + (with-single-undo + (goto-char (make-mark (mark-line point) + (- (mark-charpos point) (length *prefix*)))) + (set-mark point) + (delete-region) + (insert completion))) + (setf *current-command* 'complete)) + (values)) + +(map-key-for-mode "Ctrl Space" "(complete)" "Lisp") +(map-key-for-mode "Ctrl Space" "(complete)" "Lisp Shell") Added: trunk/abcl/examples/init.lisp ============================================================================== --- (empty file) +++ trunk/abcl/examples/init.lisp Wed Jun 9 07:17:17 2010 @@ -0,0 +1,112 @@ +;;; init.lisp +;;; $Id: init.lisp,v 1.36 2007-03-04 19:08:11 piso Exp $ + +;;; ~/.j/init.lisp (if it exists) is loaded automatically when j starts up. + +(defun java-version () + (jstatic "getProperty" "java.lang.System" "java.version")) + +(defun adjust-appearance () + (when (member (subseq (java-version) 0 5) + '("1.4.0" "1.4.1" "1.4.2" "1.5.0" "1.6.0" "1.7.0") + :test #'string=) + (set-global-property "adjustAscent" -2) + (set-global-property "adjustLeading" -2) + (reset-display))) + +;; Do it now! +(adjust-appearance) + +;; Turn off the remove-trailing-whitespace preference for files in the +;; directory ~/gcl/ansi-tests. +(defun my-open-file-hook (buf) + (let ((pathname (buffer-pathname buf))) + (when (and pathname + (string= (directory-namestring pathname) + "/home/peter/gcl/ansi-tests/")) + (set-buffer-property "removeTrailingWhitespace" nil)))) + +(add-hook 'open-file-hook 'my-open-file-hook) + +;; Helper function for MY-BUFFER-ACTIVATED-HOOK. +(defun sub-p (namestring dirname) + "Returns T if NAMESTRING is in DIRNAME or one of its subdirectories" + (let ((dirname-length (length dirname))) + (and (> (length namestring) dirname-length) + (string= (subseq namestring 0 dirname-length) dirname)))) + +(defun my-buffer-activated-hook (buf) + (let ((pathname (buffer-pathname buf))) + ;; PATHNAME might be NIL (not all buffers have associated files). + (when pathname + (let ((type (pathname-type pathname))) + ;; We only care about Lisp and Java buffers. + (cond ((string= type "el") + (set-buffer-property + "tagPath" + "/home/peter/emacs-21.3/lisp:/home/peter/emacs-21.3/lisp/emacs-lisp")) + ((member type '("lisp" "lsp" "cl" "java") :test 'string=) + (let* ((namestring (namestring pathname)) + (tagpath + (cond ((sub-p namestring "/home/peter/cmucl/src/") + "/home/peter/cmucl/src/code:/home/peter/cmucl/src/compiler:/home/peter/cmucl/src/pcl") + ((sub-p namestring "/home/peter/cl-bench/") + "/home/peter/cl-bench:/home/peter/cl-bench/files:/home/peter/depot/j/src/org/armedbear/lisp") + ((sub-p namestring "/home/peter/gcl/ansi-tests/") + "/home/peter/gcl/ansi-tests:/home/peter/depot/j/src/org/armedbear/lisp") + ((sub-p namestring "/home/peter/phemlock") + "/home/peter/phemlock/src/core:/home/peter/phemlock/src/user") + ((sub-p namestring "/home/peter/sbcl") + "/home/peter/sbcl/src/code:/home/peter/sbcl/src/compiler") + (t ; default case: no change + nil)))) + ;; If we end up here with a non-NIL TAGPATH, use it to set the + ;; buffer-specific value of the TAG-PATH preference for the current + ;; buffer. + (when tagpath + (set-buffer-property "tagPath" tagpath))))))))) + +;; Install our hook function. +(add-hook 'buffer-activated-hook 'my-buffer-activated-hook) + +;; Call ADJUST-APPEARANCE after saving ~/.j/prefs. +(defun my-after-save-hook (buf) + (let ((pathname (buffer-pathname buf))) + (when (equal pathname #p"/home/peter/.j/prefs") + (adjust-appearance)))) + +(add-hook 'after-save-hook 'my-after-save-hook) + +(defun reset-incoming-filters () + (jstatic "resetIncomingFilters" "org.armedbear.j.mail.IncomingFilter")) + +(defun add-incoming-filter (mailbox pattern action parameter) + (jstatic "addIncomingFilter" "org.armedbear.j.mail.IncomingFilter" + mailbox pattern action parameter)) + +(add-hook 'mailbox-mode-hook + (lambda () + (reset-incoming-filters) + (add-incoming-filter "inbox" + "~C linux-kernel" + "move" + "mail/linux-kernel") + (add-incoming-filter "inbox" + "~C ix.netcom.com" + "move" + "mail/netcom"))) + +(defun maybe-load (pathname) + (when (probe-file pathname) + (load pathname))) + +(maybe-load "/home/peter/.j/key-pressed.lisp") +(maybe-load "/home/peter/.j/update-check-enabled.lisp") + +(maybe-load #+windows "c:/cygwin/home/peter/j/build-abcl.lisp" + #-windows "/home/peter/j/build-abcl.lisp") + +(map-key-for-mode ")" "electricCloseParen" "Lisp Shell") + +(map-key-for-mode "[" "insertParentheses" "Lisp") +(map-key-for-mode "]" "movePastCloseAndReindent" "Lisp") Added: trunk/abcl/examples/key-pressed.lisp ============================================================================== --- (empty file) +++ trunk/abcl/examples/key-pressed.lisp Wed Jun 9 07:17:17 2010 @@ -0,0 +1,169 @@ +;;; key-pressed.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: key-pressed.lisp,v 1.8 2005-11-18 01:47:25 piso Exp $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(unless (find-package "KEY-PRESSED") + (make-package "KEY-PRESSED" :nicknames '("KP") :use '("CL" "J"))) + +(in-package "KEY-PRESSED") + +;; No exports. + +(defcommand open-file) +(defcommand open-file-in-other-window) +(defcommand open-file-in-other-frame) +;; (defcommand new-buffer) +(defcommand recent-files) +(defcommand save) +(defcommand save-as) +(defcommand save-copy) +(defcommand save-all) +(defcommand kill-buffer) +(defcommand properties) +(defcommand next-buffer) +(defcommand prev-buffer) +(defcommand new-frame) +;; (defcommand execute-command "executeCommand") +;; (defcommand j-print "print") +(defcommand save-all-exit) +(defcommand quit) +(defcommand jump-to-line) +(defcommand jump-to-column) +(defcommand j-find "find") +(defcommand incremental-find) +(defcommand list-occurrences) +(defcommand find-in-files) +(defcommand list-files) +(defcommand sidebar-list-tags) +(defcommand j-replace "replace") +(defcommand replace-in-files) +(defcommand dir) +(defcommand goto-bookmark) +(defcommand help) +(defcommand describe-key) +(defcommand next-frame) +(defcommand select-word) +(defcommand kill-frame) +(defcommand toggle-sidebar) +(defcommand sidebar-list-buffers) +(defcommand split-window) +(defcommand unsplit-window) +(defcommand other-window) +(defcommand shell) + +;;; Incremental find needs special handling. +(defun invoke-incremental-find () + (location-bar-cancel-input) + (restore-focus) + (invoke-later 'incremental-find)) + +(defvar *table* (make-hash-table :test #'equalp)) + +;;; Object can be a symbol or a function. +(defun assign-key (key object) + (setf (gethash key *table*) object)) + +;;; The hook function. +(defun key-pressed (&rest args) + (let* ((key (car args)) + (value (gethash key *table*))) + (when (and value + (or (functionp value) + (and (symbolp value) (fboundp value)))) + (funcall value)))) + +;;; Key assignments. +(assign-key "Ctrl O" + #'(lambda () + (location-bar-cancel-input) + (update-location-bar) + (open-file))) +(assign-key "Ctrl Alt O" + #'(lambda () (open-file-in-other-window) (update-location-bar))) +(assign-key "Ctrl Shift O" 'open-file-in-other-frame) +;; Ctrl N is used for history in textfields. +;; (assign-key "Ctrl N" 'new-buffer) +(assign-key "Alt R" 'recent-files) +(assign-key "Ctrl S" 'save) +(assign-key "Ctrl Shift S" 'save-as) +(assign-key "Ctrl Alt S" 'save-copy) +(assign-key "F2" 'save-all) +(assign-key "Ctrl F4" 'kill-buffer) +(assign-key "Ctrl W" 'kill-buffer) +(assign-key "Alt P" 'properties) +(assign-key "Alt NumPad Right" + #'(lambda () (restore-focus) (next-buffer))) +(assign-key "Alt Right" + #'(lambda () (restore-focus) (next-buffer))) +(assign-key "Alt NumPad Left" + #'(lambda () (restore-focus) (prev-buffer))) +(assign-key "Alt Left" + #'(lambda () (restore-focus) (prev-buffer))) +(assign-key "Ctrl Shift N" 'new-frame) +(assign-key "Alt X" 'execute-command) +;; Ctrl P is used for history in textfields. +;; (assign-key "Ctrl P" 'j-print) +(assign-key "Ctrl Shift Q" 'save-all-exit) +(assign-key "Ctrl Q" 'quit) +(assign-key "Ctrl J" 'jump-to-line) +(assign-key "Ctrl Shift J" 'jump-to-column) +(assign-key "Alt F3" + #'(lambda () (location-bar-cancel-input) (restore-focus) (j-find))) +(assign-key "Ctrl F" 'invoke-incremental-find) +(assign-key "Alt L" 'list-occurrences) +(assign-key "F6" 'find-in-files) +(assign-key "Ctrl Shift F" 'find-in-files) +(assign-key "Ctrl L" 'list-files) +(assign-key "Ctrl Shift L" 'sidebar-list-tags) +(assign-key "Ctrl R" 'j-replace) +(assign-key "Ctrl Shift R" 'replace-in-files) +(assign-key "Ctrl D" 'dir) +(assign-key "Ctrl 0" 'goto-bookmark) +(assign-key "Ctrl 1" 'goto-bookmark) +(assign-key "Ctrl 2" 'goto-bookmark) +(assign-key "Ctrl 3" 'goto-bookmark) +(assign-key "Ctrl 4" 'goto-bookmark) +(assign-key "Ctrl 5" 'goto-bookmark) +(assign-key "Ctrl 6" 'goto-bookmark) +(assign-key "Ctrl 7" 'goto-bookmark) +(assign-key "Ctrl 8" 'goto-bookmark) +(assign-key "Ctrl 9" 'goto-bookmark) +(assign-key "F1" 'help) +(assign-key "Alt K" 'describe-key) +(assign-key "Alt N" 'next-frame) +(assign-key "Alt W" 'select-word) +(assign-key "Ctrl Shift W" 'kill-frame) +(assign-key "Alt =" 'toggle-sidebar) +(assign-key "Alt B" 'sidebar-list-buffers) +(assign-key "F10" 'split-window) +(assign-key "Shift F10" 'unsplit-window) +(assign-key "Alt O" 'other-window) +(assign-key "Alt F9" + #'(lambda () (restore-focus) (shell))) + +;;; Enable the hook. +(add-hook 'key-pressed-hook 'key-pressed) +(set-global-property "enableKeyPressedHook" t) + +;; NOTE: ENABLE-KEY-PRESSED-HOOK will be reset to its default value (NIL) when +;; preferences are reloaded (which happens automatically when you edit your +;; preferences file). To prevent this (and keep the key-pressed hook working +;; properly across preference file edits), add this line to ~/.j/prefs: +;; +;; enableKeyPressedHook = true +;; Modified: trunk/abcl/nbproject/build-impl.xml ============================================================================== --- trunk/abcl/nbproject/build-impl.xml (original) +++ trunk/abcl/nbproject/build-impl.xml Wed Jun 9 07:17:17 2010 @@ -20,13 +20,6 @@ --> - - - - - - - @@ -190,23 +152,14 @@ - - + - - - - - - - - + - - + @@ -245,7 +198,7 @@ - + @@ -260,7 +213,6 @@ - @@ -317,11 +269,8 @@ - - - @@ -338,16 +287,12 @@ - - - - - + @@ -371,22 +316,7 @@ COMPILATION SECTION =================== --> - - - - - - - - - - - - - - - - + @@ -402,15 +332,10 @@ - - - - - - + - + @@ -427,7 +352,7 @@ Must select some files in the IDE or set javac.includes - + @@ -447,10 +372,10 @@ - + - + @@ -493,53 +418,11 @@ java -jar "${dist.jar.resolved}" - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - - - - - - - - - - - - - - - + - + - - - - - - - - - - - - - - - - Modified: trunk/abcl/nbproject/genfiles.properties ============================================================================== --- trunk/abcl/nbproject/genfiles.properties (original) +++ trunk/abcl/nbproject/genfiles.properties Wed Jun 9 07:17:17 2010 @@ -4,8 +4,8 @@ # This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml. # Do not edit this file. You may delete it but then the IDE will never regenerate such files for you. nbproject/build-impl.xml.data.CRC32=742204ce -nbproject/build-impl.xml.script.CRC32=29122cc4 -nbproject/build-impl.xml.stylesheet.CRC32=576378a2 at 1.32.1.45 +nbproject/build-impl.xml.script.CRC32=b7bf05a5 +nbproject/build-impl.xml.stylesheet.CRC32=65b8de21 nbproject/profiler-build-impl.xml.data.CRC32=71623fcd nbproject/profiler-build-impl.xml.script.CRC32=abda56ed nbproject/profiler-build-impl.xml.stylesheet.CRC32=42cb6bcf Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Wed Jun 9 07:17:17 2010 @@ -97,7 +97,7 @@ symbol.setSymbolFunction(new Autoload(symbol, null, "org.armedbear.lisp.".concat(className))); } - + public void load() { if (className != null) { @@ -684,9 +684,6 @@ autoload(Symbol.COPY_LIST, "copy_list"); - autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false); - autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false); - autoload(Symbol.SET_CHAR, "StringFunctions"); autoload(Symbol.SET_SCHAR, "StringFunctions"); Modified: trunk/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Function.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Function.java Wed Jun 9 07:17:17 2010 @@ -175,51 +175,23 @@ new JavaObject(bytes)); } - public final LispObject getClassBytes() { - LispObject o = getf(propertyList, Symbol.CLASS_BYTES, NIL); - if(o != NIL) { - return o; - } else { - ClassLoader c = getClass().getClassLoader(); - if(c instanceof FaslClassLoader) { - return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this)); - } else { - return NIL; - } - } - } - - public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes(); - public static final class pf_function_class_bytes extends Primitive { - public pf_function_class_bytes() { - super("function-class-bytes", PACKAGE_SYS, false, "function"); - } - @Override - public LispObject execute(LispObject arg) { - if (arg instanceof Function) { - return ((Function) arg).getClassBytes(); - } - return type_error(arg, Symbol.FUNCTION); - } - } - @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this, 0)); + return error(new WrongNumberOfArgumentsException(this)); } @Override public LispObject execute(LispObject arg) { - return error(new WrongNumberOfArgumentsException(this, 1)); + return error(new WrongNumberOfArgumentsException(this)); } @Override public LispObject execute(LispObject first, LispObject second) { - return error(new WrongNumberOfArgumentsException(this, 2)); + return error(new WrongNumberOfArgumentsException(this)); } @Override @@ -227,7 +199,7 @@ LispObject third) { - return error(new WrongNumberOfArgumentsException(this, 3)); + return error(new WrongNumberOfArgumentsException(this)); } @Override @@ -235,7 +207,7 @@ LispObject third, LispObject fourth) { - return error(new WrongNumberOfArgumentsException(this, 4)); + return error(new WrongNumberOfArgumentsException(this)); } @Override @@ -244,7 +216,7 @@ LispObject fifth) { - return error(new WrongNumberOfArgumentsException(this, 5)); + return error(new WrongNumberOfArgumentsException(this)); } @Override @@ -253,7 +225,7 @@ LispObject fifth, LispObject sixth) { - return error(new WrongNumberOfArgumentsException(this, 6)); + return error(new WrongNumberOfArgumentsException(this)); } @Override @@ -263,7 +235,7 @@ LispObject seventh) { - return error(new WrongNumberOfArgumentsException(this, 7)); + return error(new WrongNumberOfArgumentsException(this)); } @Override @@ -273,7 +245,7 @@ LispObject seventh, LispObject eighth) { - return error(new WrongNumberOfArgumentsException(this, 8)); + return error(new WrongNumberOfArgumentsException(this)); } @Override Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Wed Jun 9 07:17:17 2010 @@ -177,7 +177,7 @@ } catch (ClassNotFoundException e) { } // FIXME: what to do? - Load.loadSystemFile("j.lisp", false); // not being autoloaded + Load.loadSystemFile("j.lisp"); initialized = true; } @@ -217,7 +217,7 @@ private static synchronized void initializeSystem() { - Load.loadSystemFile("system", false); // not being autoloaded + Load.loadSystemFile("system"); } // Check for --noinit; verify that arguments are supplied for --load and @@ -308,7 +308,7 @@ false, false, true); else - Load.loadSystemFile(args[i + 1], false); // not being autoloaded + Load.loadSystemFile(args[i + 1]); ++i; } else { // Shouldn't happen. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Jun 9 07:17:17 2010 @@ -43,6 +43,8 @@ import java.net.URL; import java.net.URLDecoder; import java.util.Hashtable; +import java.util.zip.ZipEntry; +import java.util.zip.ZipFile; public final class Lisp { @@ -699,8 +701,9 @@ * * This version is used by the interpreter. */ - static final LispObject nonLocalGo(Binding binding, - LispObject tag) + public static final LispObject nonLocalGo(Binding binding, + LispObject tag) + { if (binding.env.inactive) return error(new ControlError("Unmatched tag " @@ -735,9 +738,10 @@ * * This version is used by the interpreter. */ - static final LispObject nonLocalReturn(Binding binding, - Symbol block, - LispObject result) + public static final LispObject nonLocalReturn(Binding binding, + Symbol block, + LispObject result) + { if (binding == null) { @@ -1264,7 +1268,6 @@ url = Lisp.class.getResource(name.getNamestring()); input = url.openStream(); } catch (IOException e) { - System.err.println("Failed to read class bytes from boot class " + url); error(new LispError("Failed to read class bytes from boot class " + url)); } } @@ -2384,10 +2387,6 @@ public static final Symbol _LOAD_STREAM_ = internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL); - // ### *fasl-loader* - public static final Symbol _FASL_LOADER_ = - exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL); - // ### *source* // internal symbol public static final Symbol _SOURCE_ = @@ -2761,16 +2760,4 @@ Symbol.DEBUG_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true)); } - private static final SpecialOperator WITH_INLINE_CODE = new with_inline_code(); - private static class with_inline_code extends SpecialOperator { - with_inline_code() { - super("with-inline-code", PACKAGE_JVM, true, "(&optional target repr) &body body"); - } - @Override - public LispObject execute(LispObject args, Environment env) - { - return error(new SimpleError("This is a placeholder. It should only be called in compiled code, and tranformed by the compiler using special form handlers.")); - } - } - } Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Wed Jun 9 07:17:17 2010 @@ -216,6 +216,16 @@ } } + public static final LispObject loadSystemFile(String filename) + + { + final LispThread thread = LispThread.currentThread(); + return loadSystemFile(filename, + Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL, + Symbol.LOAD_PRINT.symbolValue(thread) != NIL, + false); + } + public static final LispObject loadSystemFile(String filename, boolean auto) { @@ -242,7 +252,6 @@ } } - private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*"); static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_"); public static final LispObject loadSystemFile(final String filename, @@ -269,7 +278,7 @@ String path = pathname.asEntryPath(); url = Lisp.class.getResource(path); if (url == null || url.toString().endsWith("/")) { - url = Lisp.class.getResource(path.replace('-', '_') + ".abcl"); + url = Lisp.class.getResource(path + ".abcl"); if (url == null) { url = Lisp.class.getResource(path + ".lisp"); } @@ -323,7 +332,6 @@ final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL); - thread.bindSpecial(FASL_LOADER, NIL); try { Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER); return loadFileFromStream(pathname, truename, stream, @@ -432,12 +440,6 @@ in, verbose, print, auto, false); } - private static Symbol[] savedSpecials = - new Symbol[] { // CLHS Specified - Symbol.CURRENT_READTABLE, Symbol._PACKAGE_, - // Compiler policy - _SPEED_, _SPACE_, _SAFETY_, _DEBUG_, _EXPLAIN_ }; - // A nil TRUENAME signals a load from stream which has no possible path private static final LispObject loadFileFromStream(LispObject pathname, LispObject truename, @@ -451,12 +453,18 @@ long start = System.currentTimeMillis(); final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); - - for (Symbol special : savedSpecials) - thread.bindSpecialToCurrentValue(special); - + // "LOAD binds *READTABLE* and *PACKAGE* to the values they held before + // loading the file." + thread.bindSpecialToCurrentValue(Symbol.CURRENT_READTABLE); + thread.bindSpecialToCurrentValue(Symbol._PACKAGE_); int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue(thread)); thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth)); + // Compiler policy. + thread.bindSpecialToCurrentValue(_SPEED_); + thread.bindSpecialToCurrentValue(_SPACE_); + thread.bindSpecialToCurrentValue(_SAFETY_); + thread.bindSpecialToCurrentValue(_DEBUG_); + thread.bindSpecialToCurrentValue(_EXPLAIN_); final String prefix = getLoadVerbosePrefix(loadDepth); try { thread.bindSpecial(Symbol.LOAD_PATHNAME, pathname); @@ -553,6 +561,12 @@ } private static final LispObject loadStream(Stream in, boolean print, + LispThread thread) + { + return loadStream(in, print, thread, false); + } + + private static final LispObject loadStream(Stream in, boolean print, LispThread thread, boolean returnLastResult) { @@ -569,7 +583,7 @@ thread, Stream.currentReadtable); if (obj == EOF) break; - result = eval(obj, env, thread); + result = eval(obj, env, thread); if (print) { Stream out = checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread)); Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Readtable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Wed Jun 9 07:17:17 2010 @@ -171,19 +171,19 @@ } @Override - public final LispObject typeOf() + public LispObject typeOf() { return Symbol.READTABLE; } @Override - public final LispObject classOf() + public LispObject classOf() { return BuiltInClass.READTABLE; } @Override - public final LispObject typep(LispObject type) + public LispObject typep(LispObject type) { if (type == Symbol.READTABLE) return T; @@ -193,27 +193,27 @@ } @Override - public final String toString() + public String toString() { return unreadableString("READTABLE"); } - public final LispObject getReadtableCase() + public LispObject getReadtableCase() { return readtableCase; } - public final boolean isWhitespace(char c) + public boolean isWhitespace(char c) { return getSyntaxType(c) == SYNTAX_TYPE_WHITESPACE; } - public final byte getSyntaxType(char c) + public byte getSyntaxType(char c) { return syntax.get(c); } - public final boolean isInvalid(char c) + public boolean isInvalid(char c) { switch (c) { @@ -230,7 +230,7 @@ } } - public final void checkInvalid(char c, Stream stream) + public void checkInvalid(char c, Stream stream) { // "... no mechanism is provided for changing the constituent trait of a // character." (2.1.4.2) @@ -247,12 +247,12 @@ } } - public final LispObject getReaderMacroFunction(char c) + public LispObject getReaderMacroFunction(char c) { return readerMacroFunctions.get(c); } - final LispObject getMacroCharacter(char c) + LispObject getMacroCharacter(char c) { LispObject function = getReaderMacroFunction(c); LispObject non_terminating_p; @@ -271,7 +271,7 @@ return LispThread.currentThread().setValues(function, non_terminating_p); } - final void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p) + void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p) { byte syntaxType; if (non_terminating_p != NIL) @@ -284,7 +284,7 @@ dispatchTables.put(dispChar, new DispatchTable()); } - public final LispObject getDispatchMacroCharacter(char dispChar, char subChar) + public LispObject getDispatchMacroCharacter(char dispChar, char subChar) { DispatchTable dispatchTable = dispatchTables.get(dispChar); @@ -299,7 +299,7 @@ return (function != null) ? function : NIL; } - public final void setDispatchMacroCharacter(char dispChar, char subChar, + public void setDispatchMacroCharacter(char dispChar, char subChar, LispObject function) { Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Wed Jun 9 07:17:17 2010 @@ -44,12 +44,6 @@ slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; } - public SlotDefinition(StandardClass clazz) - { - super(clazz, clazz.getClassLayout().getLength()); - slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; - } - public SlotDefinition(LispObject name, LispObject readers) { this(); @@ -119,20 +113,15 @@ return unreadableString(sb.toString()); } - // ### make-slot-definition &optional class + // ### make-slot-definition private static final Primitive MAKE_SLOT_DEFINITION = - new Primitive("make-slot-definition", PACKAGE_SYS, true, "&optional class") + new Primitive("make-slot-definition", PACKAGE_SYS, true, "") { @Override public LispObject execute() { return new SlotDefinition(); } - @Override - public LispObject execute(LispObject slotDefinitionClass) - { - return new SlotDefinition((StandardClass) slotDefinitionClass); - } }; // ### %slot-definition-name Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Wed Jun 9 07:17:17 2010 @@ -384,11 +384,6 @@ STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions()); } - public static final StandardClass DIRECT_SLOT_DEFINITION = - addStandardClass(Symbol.DIRECT_SLOT_DEFINITION, list(SLOT_DEFINITION)); - public static final StandardClass EFFECTIVE_SLOT_DEFINITION = - addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION)); - // BuiltInClass.FUNCTION is also null here (see previous comment). public static final StandardClass GENERIC_FUNCTION = addStandardClass(Symbol.GENERIC_FUNCTION, list(BuiltInClass.FUNCTION, @@ -726,13 +721,6 @@ // There are no inherited slots. SLOT_DEFINITION.setSlotDefinitions(SLOT_DEFINITION.getDirectSlotDefinitions()); - DIRECT_SLOT_DEFINITION.setCPL(DIRECT_SLOT_DEFINITION, SLOT_DEFINITION, - STANDARD_OBJECT, BuiltInClass.CLASS_T); - DIRECT_SLOT_DEFINITION.finalizeClass(); - EFFECTIVE_SLOT_DEFINITION.setCPL(EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION, - STANDARD_OBJECT, BuiltInClass.CLASS_T); - EFFECTIVE_SLOT_DEFINITION.finalizeClass(); - // STANDARD-METHOD Debug.assertTrue(STANDARD_METHOD.isFinalized()); STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, STANDARD_OBJECT, Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Wed Jun 9 07:17:17 2010 @@ -1138,7 +1138,8 @@ sb.setLength(0); sb.append(readMultipleEscape(rt)); flags = new BitSet(sb.length()); - flags.set(0, sb.length()); + for (int i = sb.length(); i-- > 0;) + flags.set(i); } else if (rt.isInvalid(c)) { rt.checkInvalid(c, this); // Signals a reader-error. } else if (readtableCase == Keyword.UPCASE) { @@ -1179,7 +1180,8 @@ int end = sb.length(); if (flags == null) flags = new BitSet(sb.length()); - flags.set(begin, end); + for (int i = begin; i < end; i++) + flags.set(i); continue; } if (readtableCase == Keyword.UPCASE) Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jun 9 07:17:17 2010 @@ -2943,10 +2943,6 @@ PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST"); public static final Symbol STANDARD_READER_METHOD = PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); - public static final Symbol DIRECT_SLOT_DEFINITION = - PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION"); - public static final Symbol EFFECTIVE_SLOT_DEFINITION = - PACKAGE_MOP.addExternalSymbol("EFFECTIVE-SLOT-DEFINITION"); // Java interface. public static final Symbol JAVA_EXCEPTION = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jun 9 07:17:17 2010 @@ -60,8 +60,6 @@ (defconstant +the-standard-generic-function-class+ (find-class 'standard-generic-function)) (defconstant +the-T-class+ (find-class 'T)) -(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition)) -(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition)) ;; Don't use DEFVAR, because that disallows loading clos.lisp ;; after compiling it: the binding won't get assigned to T anymore @@ -261,45 +259,40 @@ (defun make-initfunction (initform) `(function (lambda () ,initform))) -(defun init-slot-definition (slot &key name - (initargs ()) - (initform nil) - (initfunction nil) - (readers ()) - (writers ()) - (allocation :instance) - (allocation-class nil) - &allow-other-keys) - (set-slot-definition-name slot name) - (set-slot-definition-initargs slot initargs) - (set-slot-definition-initform slot initform) - (set-slot-definition-initfunction slot initfunction) - (set-slot-definition-readers slot readers) - (set-slot-definition-writers slot writers) - (set-slot-definition-allocation slot allocation) - (set-slot-definition-allocation-class slot allocation-class) - slot) - -(defun make-direct-slot-definition (class &rest args) - (let ((slot-class (direct-slot-definition-class class))) - (if (eq slot-class +the-direct-slot-definition-class+) - (let ((slot (make-slot-definition +the-direct-slot-definition-class+))) - (apply #'init-slot-definition slot :allocation-class class args) - slot) - (progn - (let ((slot (apply #'make-instance slot-class :allocation-class class - args))) - slot))))) - -(defun make-effective-slot-definition (class &rest args) - (let ((slot-class (effective-slot-definition-class class))) - (if (eq slot-class +the-effective-slot-definition-class+) - (let ((slot (make-slot-definition +the-effective-slot-definition-class+))) - (apply #'init-slot-definition slot args) - slot) - (progn - (let ((slot (apply #'make-instance slot-class args))) - slot))))) +(defun make-direct-slot-definition (class &key name + (initargs ()) + (initform nil) + (initfunction nil) + (readers ()) + (writers ()) + (allocation :instance) + &allow-other-keys) + (let ((slot (make-slot-definition))) + (set-slot-definition-name slot name) + (set-slot-definition-initargs slot initargs) + (set-slot-definition-initform slot initform) + (set-slot-definition-initfunction slot initfunction) + (set-slot-definition-readers slot readers) + (set-slot-definition-writers slot writers) + (set-slot-definition-allocation slot allocation) + (set-slot-definition-allocation-class slot class) + slot)) + +(defun make-effective-slot-definition (&key name + (initargs ()) + (initform nil) + (initfunction nil) + (allocation :instance) + (allocation-class nil) + &allow-other-keys) + (let ((slot (make-slot-definition))) + (set-slot-definition-name slot name) + (set-slot-definition-initargs slot initargs) + (set-slot-definition-initform slot initform) + (set-slot-definition-initfunction slot initfunction) + (set-slot-definition-allocation slot allocation) + (set-slot-definition-allocation-class slot allocation-class) + slot)) ;;; finalize-inheritance @@ -462,10 +455,10 @@ all-names))) (defun std-compute-effective-slot-definition (class direct-slots) + (declare (ignore class)) (let ((initer (find-if-not #'null direct-slots :key #'%slot-definition-initfunction))) (make-effective-slot-definition - class :name (%slot-definition-name (car direct-slots)) :initform (if initer (%slot-definition-initform initer) @@ -566,12 +559,6 @@ :direct-default-initargs direct-default-initargs) class)) -;(defun convert-to-direct-slot-definition (class canonicalized-slot) -; (apply #'make-instance -; (apply #'direct-slot-definition-class -; class canonicalized-slot) -; canonicalized-slot)) - (defun std-after-initialization-for-classes (class &key direct-superclasses direct-slots direct-default-initargs @@ -1912,17 +1899,7 @@ (redefine-class-forwarder class-direct-default-initargs direct-default-initargs) (redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs) -(defgeneric direct-slot-definition-class (class &rest initargs)) - -(defmethod direct-slot-definition-class ((class class) &rest initargs) - (declare (ignore initargs)) - +the-direct-slot-definition-class+) - -(defgeneric effective-slot-definition-class (class &rest initargs)) -(defmethod effective-slot-definition-class ((class class) &rest initargs) - (declare (ignore initargs)) - +the-effective-slot-definition-class+) (fmakunbound 'documentation) (defgeneric documentation (x doc-type)) @@ -2235,17 +2212,6 @@ (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) (std-shared-initialize instance slot-names initargs)) -(defmethod shared-initialize ((slot slot-definition) slot-names - &rest initargs - &key name initargs initform initfunction - readers writers allocation - &allow-other-keys) - ;;Keyword args are duplicated from init-slot-definition only to have - ;;them checked. - (declare (ignore slot-names)) ;;TODO? - (declare (ignore name initargs initform initfunction readers writers allocation)) - (apply #'init-slot-definition slot initargs)) - ;;; change-class (defgeneric change-class (instance new-class &key)) Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Jun 9 07:17:17 2010 @@ -40,33 +40,17 @@ (defvar *output-file-pathname*) -(defun base-classname (&optional (output-file-pathname *output-file-pathname*)) - (sanitize-class-name (pathname-name output-file-pathname))) - -(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*)) - (%format nil "~A_0" (base-classname output-file-pathname))) - (declaim (ftype (function (t) t) compute-classfile-name)) (defun compute-classfile-name (n &optional (output-file-pathname *output-file-pathname*)) "Computes the name of the class file associated with number `n'." (let ((name - (sanitize-class-name - (%format nil "~A_~D" (pathname-name output-file-pathname) n)))) + (%format nil "~A-~D" + (substitute #\_ #\. + (pathname-name output-file-pathname)) n))) (namestring (merge-pathnames (make-pathname :name name :type "cls") output-file-pathname)))) -(defun sanitize-class-name (name) - (let ((name (copy-seq name))) - (dotimes (i (length name)) - (declare (type fixnum i)) - (when (or (char= (char name i) #\-) - (char= (char name i) #\.) - (char= (char name i) #\Space)) - (setf (char name i) #\_))) - name)) - - (declaim (ftype (function () t) next-classfile-name)) (defun next-classfile-name () (compute-classfile-name (incf *class-number*))) @@ -85,14 +69,12 @@ (declaim (ftype (function (t) t) verify-load)) (defun verify-load (classfile) - #|(if (> *safety* 0) - (and classfile + (if (> *safety* 0) + (and classfile (let ((*load-truename* *output-file-pathname*)) (report-error (load-compiled-function classfile)))) - t)|# - (declare (ignore classfile)) - t) + t)) (declaim (ftype (function (t) t) process-defconstant)) (defun process-defconstant (form) @@ -162,7 +144,6 @@ (parse-body body) (let* ((expr `(lambda ,lambda-list , at decls (block ,block-name , at body))) - (saved-class-number *class-number*) (classfile (next-classfile-name)) (internal-compiler-errors nil) (result (with-open-file @@ -187,8 +168,7 @@ compiled-function) (setf form `(fset ',name - (sys::get-fasl-function *fasl-loader* - ,saved-class-number) + (proxy-preloaded-function ',name ,(file-namestring classfile)) ,*source-position* ',lambda-list ,doc)) @@ -245,7 +225,6 @@ (let ((name (second form))) (eval form) (let* ((expr (function-lambda-expression (macro-function name))) - (saved-class-number *class-number*) (classfile (next-classfile-name))) (with-open-file (f classfile @@ -262,10 +241,14 @@ (if (special-operator-p name) `(put ',name 'macroexpand-macro (make-macro ',name - (sys::get-fasl-function *fasl-loader* ,saved-class-number))) + (proxy-preloaded-function + '(macro-function ,name) + ,(file-namestring classfile)))) `(fset ',name (make-macro ',name - (sys::get-fasl-function *fasl-loader* ,saved-class-number)) + (proxy-preloaded-function + '(macro-function ,name) + ,(file-namestring classfile))) ,*source-position* ',(third form))))))))) (DEFTYPE @@ -365,12 +348,8 @@ ;; to load the compiled functions. Note that this trickery ;; was already used in verify-load before I used it, ;; however, binding *load-truename* isn't fully compliant, I think. - (when compile-time-too - (let ((*load-truename* *output-file-pathname*) - (*fasl-loader* (make-fasl-class-loader - *class-number* - (concatenate 'string "org.armedbear.lisp." (base-classname)) - nil))) + (let ((*load-truename* *output-file-pathname*)) + (when compile-time-too (eval form)))) (declaim (ftype (function (t) t) convert-ensure-method)) @@ -387,8 +366,7 @@ (eq (%car function-form) 'FUNCTION)) (let ((lambda-expression (cadr function-form))) (jvm::with-saved-compiler-policy - (let* ((saved-class-number *class-number*) - (classfile (next-classfile-name)) + (let* ((classfile (next-classfile-name)) (result (with-open-file (f classfile @@ -401,8 +379,7 @@ (declare (ignore result)) (cond (compiled-function (setf (getf tail key) - `(sys::get-fasl-function *fasl-loader* ,saved-class-number))) -;; `(load-compiled-function ,(file-namestring classfile)))) + `(load-compiled-function ,(file-namestring classfile)))) (t ;; FIXME This should be a warning or error of some sort... (format *error-output* "; Unable to compile method~%"))))))))) @@ -435,7 +412,6 @@ (return-from convert-toplevel-form (precompiler:precompile-form form nil *compile-file-environment*))) (let* ((expr `(lambda () ,form)) - (saved-class-number *class-number*) (classfile (next-classfile-name)) (result (with-open-file @@ -449,7 +425,7 @@ (declare (ignore result)) (setf form (if compiled-function - `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number)) + `(funcall (load-compiled-function ,(file-namestring classfile))) (precompiler:precompile-form form nil *compile-file-environment*))))) @@ -596,22 +572,25 @@ (write (list 'setq '*source* *compile-file-truename*) :stream out) (%stream-terpri out) - ;; Note: Beyond this point, you can't use DUMP-FORM, - ;; because the list of uninterned symbols has been fixed now. - (when *fasl-uninterned-symbols* - (write (list 'setq '*fasl-uninterned-symbols* - (coerce (mapcar #'car - (nreverse *fasl-uninterned-symbols*)) - 'vector)) - :stream out)) - (%stream-terpri out) - - (when (> *class-number* 0) - (generate-loader-function) - (write (list 'setq '*fasl-loader* - `(sys::make-fasl-class-loader - ,*class-number* - ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) + ;; Note: Beyond this point, you can't use DUMP-FORM, + ;; because the list of uninterned symbols has been fixed now. + (when *fasl-uninterned-symbols* + (write (list 'setq '*fasl-uninterned-symbols* + (coerce (mapcar #'car + (nreverse *fasl-uninterned-symbols*)) + 'vector)) + :stream out)) + (%stream-terpri out) + ;; we work with a fixed variable name here to work around the + ;; lack of availability of the circle reader in the fasl reader + ;; but it's a toplevel form anyway + (write `(dotimes (i ,*class-number*) + (function-preload + (%format nil "~A-~D.cls" + ,(substitute #\_ #\. (pathname-name output-file)) + (1+ i)))) + :stream out + :circle t) (%stream-terpri out)) @@ -630,11 +609,7 @@ (zipfile (namestring (merge-pathnames (make-pathname :type type) output-file))) - (pathnames nil) - (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls") - output-file)))) - (when (probe-file fasl-loader) - (push fasl-loader pathnames)) + (pathnames ())) (dotimes (i *class-number*) (let* ((pathname (compute-classfile-name (1+ i)))) (when (probe-file pathname) @@ -657,55 +632,6 @@ (namestring output-file) elapsed)))) (values (truename output-file) warnings-p failure-p))) -(defmacro ncase (expr min max &rest clauses) - "A CASE where all test clauses are numbers ranging from a minimum to a maximum." - ;;Expr is subject to multiple evaluation, but since we only use ncase for - ;;fn-index below, let's ignore it. - (let* ((half (floor (/ (- max min) 2))) - (middle (+ min half))) - (if (> (- max min) 10) - `(if (< ,expr ,middle) - (ncase ,expr ,min ,middle ,@(subseq clauses 0 half)) - (ncase ,expr ,middle ,max ,@(subseq clauses half))) - `(case ,expr , at clauses)))) - -(defun generate-loader-function () - (let* ((basename (base-classname)) - (expr `(lambda (fasl-loader fn-index) - (identity fasl-loader) ;;to avoid unused arg - (ncase fn-index 0 ,(1- *class-number*) - ,@(loop - :for i :from 1 :to *class-number* - :collect - (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i))) - `(,(1- i) - (jvm::with-inline-code () - (jvm::emit 'jvm::aload 1) - (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" - nil jvm::+java-object+) - (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") - (jvm::emit 'jvm::dup) - (jvm::emit-push-constant-int ,(1- i)) - (jvm::emit 'jvm::new ,class) - (jvm::emit 'jvm::dup) - (jvm::emit-invokespecial-init ,class '()) - (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction" - (list "I" jvm::+lisp-object+) jvm::+lisp-object+) - (jvm::emit 'jvm::pop)) - t)))))) - (classname (fasl-loader-classname)) - (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") - *output-file-pathname*)))) - (jvm::with-saved-compiler-policy - (jvm::with-file-compilation - (with-open-file - (f classfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (jvm:compile-defun nil expr nil - classfile f nil)))))) - (defun compile-file-if-needed (input-file &rest allargs &key force-compile &allow-other-keys) (setf input-file (truename input-file)) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Jun 9 07:17:17 2010 @@ -1298,7 +1298,7 @@ (format t "; inlining call to local function ~S~%" op))) (return-from p1-function-call (let ((*inline-declarations* - (remove op *inline-declarations* :key #'car :test #'equal))) + (remove op *inline-declarations* :key #'car))) (p1 expansion)))))) ;; FIXME @@ -1432,8 +1432,7 @@ (TRULY-THE p1-truly-the) (UNWIND-PROTECT p1-unwind-protect) (THREADS:SYNCHRONIZED-ON - p1-threads-synchronized-on) - (JVM::WITH-INLINE-CODE identity))) + p1-threads-synchronized-on))) (install-p1-handler (%car pair) (%cadr pair)))) (initialize-p1-handlers) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Jun 9 07:17:17 2010 @@ -198,8 +198,6 @@ (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF)) n))) -(defconstant +fasl-loader-class+ - "org/armedbear/lisp/FaslClassLoader") (defconstant +java-string+ "Ljava/lang/String;") (defconstant +java-object+ "Ljava/lang/Object;") (defconstant +lisp-class+ "org/armedbear/lisp/Lisp") @@ -2269,22 +2267,12 @@ local-function *declared-functions* ht g (setf g (symbol-name (gensym "LFUN"))) (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function))) - (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname))) (*code* *static-code*)) ;; fixme *declare-inline* - (declare-field g +lisp-object+ +field-access-private+) - (emit 'new class-name) - (emit 'dup) - (emit-invokespecial-init class-name '()) - - ;(emit 'ldc (pool-string (pathname-name pathname))) - ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction" - ;(list +java-string+) +lisp-object+) - -; (emit 'ldc (pool-string (file-namestring pathname))) - -; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" -; (list +java-string+) +lisp-object+) + (declare-field g +lisp-object+ +field-access-default+) + (emit 'ldc (pool-string (file-namestring pathname))) + (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" + (list +java-string+) +lisp-object+) (emit 'putstatic *this-class* g +lisp-object+) (setf *static-code* *code*) (setf (gethash local-function ht) g)))) @@ -2433,6 +2421,10 @@ (packagep form) (pathnamep form) (vectorp form) + (stringp form) + (packagep form) + (pathnamep form) + (vectorp form) (structure-object-p form) (standard-object-p form) (java:java-object-p form)) @@ -5106,8 +5098,7 @@ (local-function-function local-function))))) (emit 'getstatic *this-class* g +lisp-object+))))) ; Stack: template-function - ((and (member name *functions-defined-in-current-file* :test #'equal) - (not (notinline-p name))) + ((member name *functions-defined-in-current-file* :test #'equal) (emit 'getstatic *this-class* (declare-setf-function name) +lisp-object+) (emit-move-from-stack target)) @@ -7557,32 +7548,6 @@ ;; delay resolving the method to run-time; it's unavailable now (compile-function-call form target representation)))) -#|(defknown p2-java-jcall (t t t) t) -(define-inlined-function p2-java-jcall (form target representation) - ((and (> *speed* *safety*) - (< 1 (length form)) - (eq 'jmethod (car (cadr form))) - (every #'stringp (cdr (cadr form))))) - (let ((m (ignore-errors (eval (cadr form))))) - (if m - (let ((must-clear-values nil) - (arg-types (raw-arg-types (jmethod-params m)))) - (declare (type boolean must-clear-values)) - (dolist (arg (cddr form)) - (compile-form arg 'stack nil) - (unless must-clear-values - (unless (single-valued-p arg) - (setf must-clear-values t)))) - (when must-clear-values - (emit-clear-values)) - (dotimes (i (jarray-length raw-arg-types)) - (push (jarray-ref raw-arg-types i) arg-types)) - (emit-invokevirtual (jclass-name (jmethod-declaring-class m)) - (jmethod-name m) - (nreverse arg-types) - (jmethod-return-type m))) - ;; delay resolving the method to run-time; it's unavailable now - (compile-function-call form target representation))))|# (defknown p2-char= (t t t) t) (defun p2-char= (form target representation) @@ -8259,13 +8224,6 @@ (setf (method-handlers execute-method) (nreverse *handlers*))) t) -(defun p2-with-inline-code (form target representation) - ;;form = (with-inline-code (&optional target-var repr-var) ...body...) - (destructuring-bind (&optional target-var repr-var) (cadr form) - (eval `(let (,@(when target-var `((,target-var ,target))) - ,@(when repr-var `((,repr-var ,representation)))) - ,@(cddr form))))) - (defun compile-1 (compiland stream) (let ((*all-variables* nil) (*closure-variables* nil) @@ -8558,7 +8516,6 @@ (install-p2-handler 'java:jclass 'p2-java-jclass) (install-p2-handler 'java:jconstructor 'p2-java-jconstructor) (install-p2-handler 'java:jmethod 'p2-java-jmethod) -; (install-p2-handler 'java:jcall 'p2-java-jcall) (install-p2-handler 'char= 'p2-char=) (install-p2-handler 'characterp 'p2-characterp) (install-p2-handler 'coerce-to-function 'p2-coerce-to-function) @@ -8643,7 +8600,6 @@ (install-p2-handler 'vector-push-extend 'p2-vector-push-extend) (install-p2-handler 'write-8-bits 'p2-write-8-bits) (install-p2-handler 'zerop 'p2-zerop) - (install-p2-handler 'with-inline-code 'p2-with-inline-code) t) (initialize-p2-handlers) Modified: trunk/abcl/src/org/armedbear/lisp/disassemble.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/disassemble.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/disassemble.lisp Wed Jun 9 07:17:17 2010 @@ -47,15 +47,14 @@ (when (functionp function) (unless (compiled-function-p function) (setf function (compile nil function))) - (let ((class-bytes (function-class-bytes function))) - (when class-bytes - (with-input-from-string - (stream (disassemble-class-bytes class-bytes)) - (loop - (let ((line (read-line stream nil))) - (unless line (return)) - (write-string "; ") - (write-string line) - (terpri)))) - (return-from disassemble))) - (%format t "; Disassembly is not available.~%")))) + (when (getf (function-plist function) 'class-bytes) + (with-input-from-string + (stream (disassemble-class-bytes (getf (function-plist function) 'class-bytes))) + (loop + (let ((line (read-line stream nil))) + (unless line (return)) + (write-string "; ") + (write-string line) + (terpri)))) + (return-from disassemble))) + (%format t "; Disassembly is not available.~%"))) Modified: trunk/abcl/src/org/armedbear/lisp/gui.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gui.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/gui.lisp Wed Jun 9 07:17:17 2010 @@ -1,7 +1,5 @@ (in-package :extensions) -(require :java) - (defvar *gui-backend* :swing) (defun init-gui () Copied: trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java (from r12742, /trunk/abcl/examples/gui/abcl/DialogPromptStream.java) ============================================================================== --- /trunk/abcl/examples/gui/abcl/DialogPromptStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java Wed Jun 9 07:17:17 2010 @@ -1,4 +1,4 @@ -package abcl; +package org.armedbear.lisp.java; import java.io.IOException; import java.io.Reader; @@ -6,17 +6,12 @@ import java.io.StringWriter; import org.armedbear.lisp.Stream; - /** - * A bidirectional stream that captures input from a modal dialog. The - * dialog reports a label (prompt line) which shows to the user - * everything that has been printed to the stream up to the moment - * when the dialog became visible. It is usable as a drop-in - * replacement for e.g. *debug-io*.
        This is an abstract class - * that does not depend on any GUI library. Subclasses are expected to - * provide the actual code to show the dialog and read input from the - * user. - * + * A bidirectional stream that captures input from a modal dialog. The dialog reports a label (prompt line) + * which shows to the user everything that has been printed to the stream up to the moment when the dialog + * became visible. It is usable as a drop-in replacement for e.g. *debug-io*.
        + * This is an abstract class that does not depend on any GUI library. Subclasses are expected to provide + * the actual code to show the dialog and read input from the user. * @author Alessio Stalla * */ Copied: trunk/abcl/src/org/armedbear/lisp/java/swing/SwingDialogPromptStream.java (from r12742, /trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java) ============================================================================== --- /trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/java/swing/SwingDialogPromptStream.java Wed Jun 9 07:17:17 2010 @@ -1,4 +1,4 @@ -package swing; +package org.armedbear.lisp.java.swing; import java.awt.BorderLayout; import java.awt.FlowLayout; @@ -12,7 +12,7 @@ import javax.swing.JPanel; import javax.swing.JTextField; -import abcl.DialogPromptStream; +import org.armedbear.lisp.java.DialogPromptStream; public class SwingDialogPromptStream extends DialogPromptStream { Modified: trunk/abcl/src/org/armedbear/lisp/load.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/load.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/load.lisp Wed Jun 9 07:17:17 2010 @@ -38,11 +38,10 @@ (if-does-not-exist t) (external-format :default)) (declare (ignore external-format)) ; FIXME - (let (*fasl-loader*) - (%load (if (streamp filespec) - filespec - (merge-pathnames (pathname filespec))) - verbose print if-does-not-exist))) + (%load (if (streamp filespec) + filespec + (merge-pathnames (pathname filespec))) + verbose print if-does-not-exist)) (defun load-returning-last-result (filespec &key @@ -51,8 +50,7 @@ (if-does-not-exist t) (external-format :default)) (declare (ignore external-format)) ; FIXME - (let (*fasl-loader*) - (%load-returning-last-result (if (streamp filespec) - filespec - (merge-pathnames (pathname filespec))) - verbose print if-does-not-exist))) \ No newline at end of file + (%load-returning-last-result (if (streamp filespec) + filespec + (merge-pathnames (pathname filespec))) + verbose print if-does-not-exist)) \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed Jun 9 07:17:17 2010 @@ -32,10 +32,13 @@ (in-package "SYSTEM") -(export '(process-optimization-declarations +(export '(*inline-declarations* + process-optimization-declarations inline-p notinline-p inline-expansion expand-inline *defined-functions* *undefined-functions* note-name-defined)) +(defvar *inline-declarations* nil) + (declaim (ftype (function (t) t) process-optimization-declarations)) (defun process-optimization-declarations (forms) (dolist (form forms) @@ -83,7 +86,7 @@ (declaim (ftype (function (t) t) inline-p)) (defun inline-p (name) (declare (optimize speed)) - (let ((entry (assoc name *inline-declarations* :test #'equal))) + (let ((entry (assoc name *inline-declarations*))) (if entry (eq (cdr entry) 'INLINE) (and (symbolp name) (eq (get name '%inline) 'INLINE))))) @@ -91,7 +94,7 @@ (declaim (ftype (function (t) t) notinline-p)) (defun notinline-p (name) (declare (optimize speed)) - (let ((entry (assoc name *inline-declarations* :test #'equal))) + (let ((entry (assoc name *inline-declarations*))) (if entry (eq (cdr entry) 'NOTINLINE) (and (symbolp name) (eq (get name '%inline) 'NOTINLINE))))) @@ -958,8 +961,7 @@ (symbol-name symbol)) 'precompiler)))) (unless (and handler (fboundp handler)) - (error "No handler for ~S." (let ((*package* (find-package :keyword))) - (format nil "~S" symbol)))) + (error "No handler for ~S." symbol)) (setf (get symbol 'precompile-handler) handler))) (defun install-handlers () @@ -1022,9 +1024,7 @@ (TRULY-THE precompile-truly-the) (THREADS:SYNCHRONIZED-ON - precompile-threads-synchronized-on) - - (JVM::WITH-INLINE-CODE precompile-identity))) + precompile-threads-synchronized-on))) (install-handler (first pair) (second pair)))) (install-handlers) Modified: trunk/abcl/src/org/armedbear/lisp/proclaim.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/proclaim.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/proclaim.lisp Wed Jun 9 07:17:17 2010 @@ -31,7 +31,7 @@ (in-package #:system) -(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type *inline-declarations*)) +(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type)) (defmacro declaim (&rest decls) `(eval-when (:compile-toplevel :load-toplevel :execute) @@ -43,7 +43,6 @@ :format-control "The symbol ~S cannot be both the name of a type and the name of a declaration." :format-arguments (list name))) -(defvar *inline-declarations* nil) (defvar *declaration-types* (make-hash-table :test 'eq)) ;; "A symbol cannot be both the name of a type and the name of a declaration. @@ -92,9 +91,8 @@ (apply 'proclaim-type (cdr declaration-specifier))) ((INLINE NOTINLINE) (dolist (name (cdr declaration-specifier)) - (if (symbolp name) - (setf (get name '%inline) (car declaration-specifier)) - (push (cons name (car declaration-specifier)) *inline-declarations*)))) + (when (symbolp name) ; FIXME Need to support non-symbol function names. + (setf (get name '%inline) (car declaration-specifier))))) (DECLARATION (dolist (name (cdr declaration-specifier)) (when (or (get name 'deftype-definition) Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Wed Jun 9 07:17:17 2010 @@ -278,6 +278,7 @@ return new AbclScriptEngineFactory(); } + @Override public T getInterface(Class clasz) { try { return getInterface(eval("(cl:find-package '#:ABCL-SCRIPT-USER)"), clasz); @@ -287,12 +288,14 @@ } @SuppressWarnings("unchecked") + @Override public T getInterface(Object thiz, Class clasz) { Symbol s = findSymbol("jmake-proxy", "JAVA"); JavaObject iface = new JavaObject(clasz); return (T) ((JavaObject) s.execute(iface, (LispObject) thiz)).javaInstance(); } + @Override public Object invokeFunction(String name, Object... args) throws ScriptException, NoSuchMethodException { Symbol s; if(name.indexOf(':') >= 0) { @@ -317,6 +320,7 @@ } } + @Override public Object invokeMethod(Object thiz, String name, Object... args) throws ScriptException, NoSuchMethodException { throw new UnsupportedOperationException("Common Lisp does not have methods in the Java sense. Use invokeFunction instead."); } Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Wed Jun 9 07:17:17 2010 @@ -31,92 +31,104 @@ private static final AbclScriptEngine THE_ONLY_ONE_ENGINE = new AbclScriptEngine(); - public String getEngineName() { - return "ABCL Script"; - } - - public String getEngineVersion() { - return "0.1"; - } - - public List getExtensions() { - List extensions = new ArrayList(1); - extensions.add("lisp"); - return Collections.unmodifiableList(extensions); - } - - public String getLanguageName() { - return "ANSI Common Lisp"; - } - - public String getLanguageVersion() { - return "ANSI X3.226:1994"; - } - - public static String escape(String raw) { - StringBuilder sb = new StringBuilder(); - int len = raw.length(); - char c; - for(int i = 0; i < len; ++i) { - c = raw.charAt(i); - if(c != '"') { - sb.append(c); - } else { - sb.append("\\\""); - } + @Override + public String getEngineName() { + return "ABCL Script"; + } + + @Override + public String getEngineVersion() { + return "0.1"; + } + + @Override + public List getExtensions() { + List extensions = new ArrayList(1); + extensions.add("lisp"); + return Collections.unmodifiableList(extensions); + } + + @Override + public String getLanguageName() { + return "ANSI Common Lisp"; + } + + @Override + public String getLanguageVersion() { + return "ANSI X3.226:1994"; + } + + public static String escape(String raw) { + StringBuilder sb = new StringBuilder(); + int len = raw.length(); + char c; + for(int i = 0; i < len; ++i) { + c = raw.charAt(i); + if(c != '"') { + sb.append(c); + } else { + sb.append("\\\""); + } + } + return sb.toString(); } - return sb.toString(); - } - public String getMethodCallSyntax(String obj, String method, String... args) { - StringBuilder sb = new StringBuilder(); - sb.append("(jcall \""); - sb.append(method); - sb.append("\" "); - sb.append(obj); - for(String arg : args) { - sb.append(" "); - sb.append(arg); - } - sb.append(")"); - return sb.toString(); - } - - public List getMimeTypes() { - return Collections.unmodifiableList(new ArrayList()); - } - - public List getNames() { - List names = new ArrayList(1); - names.add("ABCL"); - names.add("cl"); - names.add("Lisp"); - names.add("Common Lisp"); - return Collections.unmodifiableList(names); - } - - public String getOutputStatement(String str) { - return "(cl:print \"" + str + "\")"; - } - - public Object getParameter(String key) { - // TODO Auto-generated method stub - return null; - } - - public String getProgram(String... statements) { - StringBuilder sb = new StringBuilder(); - sb.append("(cl:progn"); - for(String stmt : statements) { - sb.append("\n\t"); - sb.append(stmt); - } - sb.append(")"); - return sb.toString(); - } - - public ScriptEngine getScriptEngine() { - return THE_ONLY_ONE_ENGINE; - } + @Override + public String getMethodCallSyntax(String obj, String method, String... args) { + StringBuilder sb = new StringBuilder(); + sb.append("(jcall \""); + sb.append(method); + sb.append("\" "); + sb.append(obj); + for(String arg : args) { + sb.append(" "); + sb.append(arg); + } + sb.append(")"); + return sb.toString(); + } + + @Override + public List getMimeTypes() { + return Collections.unmodifiableList(new ArrayList()); + } + + @Override + public List getNames() { + List names = new ArrayList(1); + names.add("ABCL"); + names.add("cl"); + names.add("Lisp"); + names.add("Common Lisp"); + return Collections.unmodifiableList(names); + } + + @Override + public String getOutputStatement(String str) { + return "(cl:print \"" + str + "\")"; + } + + @Override + public Object getParameter(String key) { + // TODO Auto-generated method stub + return null; + } + + @Override + public String getProgram(String... statements) { + StringBuilder sb = new StringBuilder(); + sb.append("(cl:progn"); + for(String stmt : statements) { + sb.append("\n\t"); + sb.append(stmt); + } + sb.append(")"); + return sb.toString(); + } + + @Override + public ScriptEngine getScriptEngine() { + return THE_ONLY_ONE_ENGINE; + } } From mevenson at common-lisp.net Wed Jun 9 11:27:43 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 09 Jun 2010 07:27:43 -0400 Subject: [armedbear-cvs] r12749 - in trunk/abcl: . examples examples/google-app-engine examples/gui examples/gui/abcl examples/gui/awt examples/gui/swing examples/java-exception examples/java-interface examples/java-to-lisp-1 examples/java-to-lisp-2 examples/jsr-223 examples/lisp-to-java examples/misc nbproject src/org/armedbear/lisp src/org/armedbear/lisp/java src/org/armedbear/lisp/java/swing src/org/armedbear/lisp/scripting Message-ID: Author: mevenson Date: Wed Jun 9 07:27:42 2010 New Revision: 12749 Log: Undo previous commmit. Added: trunk/abcl/examples/README - copied unchanged from r12747, /trunk/abcl/examples/README trunk/abcl/examples/google-app-engine/ - copied from r12747, /trunk/abcl/examples/google-app-engine/ trunk/abcl/examples/gui/ - copied from r12747, /trunk/abcl/examples/gui/ trunk/abcl/examples/java-exception/ - copied from r12747, /trunk/abcl/examples/java-exception/ trunk/abcl/examples/java-interface/ - copied from r12747, /trunk/abcl/examples/java-interface/ trunk/abcl/examples/java-to-lisp-1/ - copied from r12747, /trunk/abcl/examples/java-to-lisp-1/ trunk/abcl/examples/java-to-lisp-2/ - copied from r12747, /trunk/abcl/examples/java-to-lisp-2/ trunk/abcl/examples/jsr-223/ - copied from r12747, /trunk/abcl/examples/jsr-223/ trunk/abcl/examples/lisp-to-java/ - copied from r12747, /trunk/abcl/examples/lisp-to-java/ trunk/abcl/examples/misc/ - copied from r12747, /trunk/abcl/examples/misc/ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java - copied unchanged from r12747, /trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java - copied unchanged from r12747, /trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java Removed: trunk/abcl/examples/.abclrc trunk/abcl/examples/complete.lisp trunk/abcl/examples/hello.java trunk/abcl/examples/init.lisp trunk/abcl/examples/key-pressed.lisp trunk/abcl/examples/update-check-enabled.lisp trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java trunk/abcl/src/org/armedbear/lisp/java/swing/SwingDialogPromptStream.java Modified: trunk/abcl/build.xml trunk/abcl/examples/gui/abcl/ (props changed) trunk/abcl/examples/gui/awt/ (props changed) trunk/abcl/examples/gui/swing/ (props changed) trunk/abcl/nbproject/build-impl.xml trunk/abcl/nbproject/genfiles.properties trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Function.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Readtable.java trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/disassemble.lisp trunk/abcl/src/org/armedbear/lisp/gui.lisp trunk/abcl/src/org/armedbear/lisp/load.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp trunk/abcl/src/org/armedbear/lisp/proclaim.lisp trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Wed Jun 9 07:27:42 2010 @@ -464,8 +464,6 @@ - - Modified: trunk/abcl/nbproject/build-impl.xml ============================================================================== --- trunk/abcl/nbproject/build-impl.xml (original) +++ trunk/abcl/nbproject/build-impl.xml Wed Jun 9 07:27:42 2010 @@ -20,6 +20,13 @@ --> + + + + + + + @@ -152,14 +190,23 @@ - + + - + + + + + + + + - + + @@ -198,7 +245,7 @@ - + @@ -213,6 +260,7 @@ + @@ -269,8 +317,11 @@ + + + @@ -287,12 +338,16 @@ + + + + - + @@ -316,7 +371,22 @@ COMPILATION SECTION =================== --> - + + + + + + + + + + + + + + + + @@ -332,10 +402,15 @@ - + + + + + + - + @@ -352,7 +427,7 @@ Must select some files in the IDE or set javac.includes - + @@ -372,10 +447,10 @@ - + - + @@ -418,11 +493,53 @@ java -jar "${dist.jar.resolved}" + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + Modified: trunk/abcl/nbproject/genfiles.properties ============================================================================== --- trunk/abcl/nbproject/genfiles.properties (original) +++ trunk/abcl/nbproject/genfiles.properties Wed Jun 9 07:27:42 2010 @@ -4,8 +4,8 @@ # This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml. # Do not edit this file. You may delete it but then the IDE will never regenerate such files for you. nbproject/build-impl.xml.data.CRC32=742204ce -nbproject/build-impl.xml.script.CRC32=b7bf05a5 -nbproject/build-impl.xml.stylesheet.CRC32=65b8de21 +nbproject/build-impl.xml.script.CRC32=29122cc4 +nbproject/build-impl.xml.stylesheet.CRC32=576378a2 at 1.32.1.45 nbproject/profiler-build-impl.xml.data.CRC32=71623fcd nbproject/profiler-build-impl.xml.script.CRC32=abda56ed nbproject/profiler-build-impl.xml.stylesheet.CRC32=42cb6bcf Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Wed Jun 9 07:27:42 2010 @@ -97,7 +97,7 @@ symbol.setSymbolFunction(new Autoload(symbol, null, "org.armedbear.lisp.".concat(className))); } - + public void load() { if (className != null) { @@ -684,6 +684,9 @@ autoload(Symbol.COPY_LIST, "copy_list"); + autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false); + autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false); + autoload(Symbol.SET_CHAR, "StringFunctions"); autoload(Symbol.SET_SCHAR, "StringFunctions"); Modified: trunk/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Function.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Function.java Wed Jun 9 07:27:42 2010 @@ -175,23 +175,51 @@ new JavaObject(bytes)); } + public final LispObject getClassBytes() { + LispObject o = getf(propertyList, Symbol.CLASS_BYTES, NIL); + if(o != NIL) { + return o; + } else { + ClassLoader c = getClass().getClassLoader(); + if(c instanceof FaslClassLoader) { + return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this)); + } else { + return NIL; + } + } + } + + public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes(); + public static final class pf_function_class_bytes extends Primitive { + public pf_function_class_bytes() { + super("function-class-bytes", PACKAGE_SYS, false, "function"); + } + @Override + public LispObject execute(LispObject arg) { + if (arg instanceof Function) { + return ((Function) arg).getClassBytes(); + } + return type_error(arg, Symbol.FUNCTION); + } + } + @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 0)); } @Override public LispObject execute(LispObject arg) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); } @Override public LispObject execute(LispObject first, LispObject second) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2)); } @Override @@ -199,7 +227,7 @@ LispObject third) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 3)); } @Override @@ -207,7 +235,7 @@ LispObject third, LispObject fourth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 4)); } @Override @@ -216,7 +244,7 @@ LispObject fifth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 5)); } @Override @@ -225,7 +253,7 @@ LispObject fifth, LispObject sixth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 6)); } @Override @@ -235,7 +263,7 @@ LispObject seventh) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 7)); } @Override @@ -245,7 +273,7 @@ LispObject seventh, LispObject eighth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 8)); } @Override Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Wed Jun 9 07:27:42 2010 @@ -177,7 +177,7 @@ } catch (ClassNotFoundException e) { } // FIXME: what to do? - Load.loadSystemFile("j.lisp"); + Load.loadSystemFile("j.lisp", false); // not being autoloaded initialized = true; } @@ -217,7 +217,7 @@ private static synchronized void initializeSystem() { - Load.loadSystemFile("system"); + Load.loadSystemFile("system", false); // not being autoloaded } // Check for --noinit; verify that arguments are supplied for --load and @@ -308,7 +308,7 @@ false, false, true); else - Load.loadSystemFile(args[i + 1]); + Load.loadSystemFile(args[i + 1], false); // not being autoloaded ++i; } else { // Shouldn't happen. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Jun 9 07:27:42 2010 @@ -43,8 +43,6 @@ import java.net.URL; import java.net.URLDecoder; import java.util.Hashtable; -import java.util.zip.ZipEntry; -import java.util.zip.ZipFile; public final class Lisp { @@ -701,9 +699,8 @@ * * This version is used by the interpreter. */ - public static final LispObject nonLocalGo(Binding binding, - LispObject tag) - + static final LispObject nonLocalGo(Binding binding, + LispObject tag) { if (binding.env.inactive) return error(new ControlError("Unmatched tag " @@ -738,10 +735,9 @@ * * This version is used by the interpreter. */ - public static final LispObject nonLocalReturn(Binding binding, - Symbol block, - LispObject result) - + static final LispObject nonLocalReturn(Binding binding, + Symbol block, + LispObject result) { if (binding == null) { @@ -1268,6 +1264,7 @@ url = Lisp.class.getResource(name.getNamestring()); input = url.openStream(); } catch (IOException e) { + System.err.println("Failed to read class bytes from boot class " + url); error(new LispError("Failed to read class bytes from boot class " + url)); } } @@ -2387,6 +2384,10 @@ public static final Symbol _LOAD_STREAM_ = internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL); + // ### *fasl-loader* + public static final Symbol _FASL_LOADER_ = + exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL); + // ### *source* // internal symbol public static final Symbol _SOURCE_ = @@ -2760,4 +2761,16 @@ Symbol.DEBUG_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true)); } + private static final SpecialOperator WITH_INLINE_CODE = new with_inline_code(); + private static class with_inline_code extends SpecialOperator { + with_inline_code() { + super("with-inline-code", PACKAGE_JVM, true, "(&optional target repr) &body body"); + } + @Override + public LispObject execute(LispObject args, Environment env) + { + return error(new SimpleError("This is a placeholder. It should only be called in compiled code, and tranformed by the compiler using special form handlers.")); + } + } + } Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Wed Jun 9 07:27:42 2010 @@ -216,16 +216,6 @@ } } - public static final LispObject loadSystemFile(String filename) - - { - final LispThread thread = LispThread.currentThread(); - return loadSystemFile(filename, - Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL, - Symbol.LOAD_PRINT.symbolValue(thread) != NIL, - false); - } - public static final LispObject loadSystemFile(String filename, boolean auto) { @@ -252,6 +242,7 @@ } } + private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*"); static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_"); public static final LispObject loadSystemFile(final String filename, @@ -278,7 +269,7 @@ String path = pathname.asEntryPath(); url = Lisp.class.getResource(path); if (url == null || url.toString().endsWith("/")) { - url = Lisp.class.getResource(path + ".abcl"); + url = Lisp.class.getResource(path.replace('-', '_') + ".abcl"); if (url == null) { url = Lisp.class.getResource(path + ".lisp"); } @@ -332,6 +323,7 @@ final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL); + thread.bindSpecial(FASL_LOADER, NIL); try { Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER); return loadFileFromStream(pathname, truename, stream, @@ -440,6 +432,12 @@ in, verbose, print, auto, false); } + private static Symbol[] savedSpecials = + new Symbol[] { // CLHS Specified + Symbol.CURRENT_READTABLE, Symbol._PACKAGE_, + // Compiler policy + _SPEED_, _SPACE_, _SAFETY_, _DEBUG_, _EXPLAIN_ }; + // A nil TRUENAME signals a load from stream which has no possible path private static final LispObject loadFileFromStream(LispObject pathname, LispObject truename, @@ -453,18 +451,12 @@ long start = System.currentTimeMillis(); final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); - // "LOAD binds *READTABLE* and *PACKAGE* to the values they held before - // loading the file." - thread.bindSpecialToCurrentValue(Symbol.CURRENT_READTABLE); - thread.bindSpecialToCurrentValue(Symbol._PACKAGE_); + + for (Symbol special : savedSpecials) + thread.bindSpecialToCurrentValue(special); + int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue(thread)); thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth)); - // Compiler policy. - thread.bindSpecialToCurrentValue(_SPEED_); - thread.bindSpecialToCurrentValue(_SPACE_); - thread.bindSpecialToCurrentValue(_SAFETY_); - thread.bindSpecialToCurrentValue(_DEBUG_); - thread.bindSpecialToCurrentValue(_EXPLAIN_); final String prefix = getLoadVerbosePrefix(loadDepth); try { thread.bindSpecial(Symbol.LOAD_PATHNAME, pathname); @@ -561,12 +553,6 @@ } private static final LispObject loadStream(Stream in, boolean print, - LispThread thread) - { - return loadStream(in, print, thread, false); - } - - private static final LispObject loadStream(Stream in, boolean print, LispThread thread, boolean returnLastResult) { @@ -583,7 +569,7 @@ thread, Stream.currentReadtable); if (obj == EOF) break; - result = eval(obj, env, thread); + result = eval(obj, env, thread); if (print) { Stream out = checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread)); Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Readtable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Wed Jun 9 07:27:42 2010 @@ -171,19 +171,19 @@ } @Override - public LispObject typeOf() + public final LispObject typeOf() { return Symbol.READTABLE; } @Override - public LispObject classOf() + public final LispObject classOf() { return BuiltInClass.READTABLE; } @Override - public LispObject typep(LispObject type) + public final LispObject typep(LispObject type) { if (type == Symbol.READTABLE) return T; @@ -193,27 +193,27 @@ } @Override - public String toString() + public final String toString() { return unreadableString("READTABLE"); } - public LispObject getReadtableCase() + public final LispObject getReadtableCase() { return readtableCase; } - public boolean isWhitespace(char c) + public final boolean isWhitespace(char c) { return getSyntaxType(c) == SYNTAX_TYPE_WHITESPACE; } - public byte getSyntaxType(char c) + public final byte getSyntaxType(char c) { return syntax.get(c); } - public boolean isInvalid(char c) + public final boolean isInvalid(char c) { switch (c) { @@ -230,7 +230,7 @@ } } - public void checkInvalid(char c, Stream stream) + public final void checkInvalid(char c, Stream stream) { // "... no mechanism is provided for changing the constituent trait of a // character." (2.1.4.2) @@ -247,12 +247,12 @@ } } - public LispObject getReaderMacroFunction(char c) + public final LispObject getReaderMacroFunction(char c) { return readerMacroFunctions.get(c); } - LispObject getMacroCharacter(char c) + final LispObject getMacroCharacter(char c) { LispObject function = getReaderMacroFunction(c); LispObject non_terminating_p; @@ -271,7 +271,7 @@ return LispThread.currentThread().setValues(function, non_terminating_p); } - void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p) + final void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p) { byte syntaxType; if (non_terminating_p != NIL) @@ -284,7 +284,7 @@ dispatchTables.put(dispChar, new DispatchTable()); } - public LispObject getDispatchMacroCharacter(char dispChar, char subChar) + public final LispObject getDispatchMacroCharacter(char dispChar, char subChar) { DispatchTable dispatchTable = dispatchTables.get(dispChar); @@ -299,7 +299,7 @@ return (function != null) ? function : NIL; } - public void setDispatchMacroCharacter(char dispChar, char subChar, + public final void setDispatchMacroCharacter(char dispChar, char subChar, LispObject function) { Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Wed Jun 9 07:27:42 2010 @@ -44,6 +44,12 @@ slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; } + public SlotDefinition(StandardClass clazz) + { + super(clazz, clazz.getClassLayout().getLength()); + slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; + } + public SlotDefinition(LispObject name, LispObject readers) { this(); @@ -113,15 +119,20 @@ return unreadableString(sb.toString()); } - // ### make-slot-definition + // ### make-slot-definition &optional class private static final Primitive MAKE_SLOT_DEFINITION = - new Primitive("make-slot-definition", PACKAGE_SYS, true, "") + new Primitive("make-slot-definition", PACKAGE_SYS, true, "&optional class") { @Override public LispObject execute() { return new SlotDefinition(); } + @Override + public LispObject execute(LispObject slotDefinitionClass) + { + return new SlotDefinition((StandardClass) slotDefinitionClass); + } }; // ### %slot-definition-name Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Wed Jun 9 07:27:42 2010 @@ -384,6 +384,11 @@ STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions()); } + public static final StandardClass DIRECT_SLOT_DEFINITION = + addStandardClass(Symbol.DIRECT_SLOT_DEFINITION, list(SLOT_DEFINITION)); + public static final StandardClass EFFECTIVE_SLOT_DEFINITION = + addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION)); + // BuiltInClass.FUNCTION is also null here (see previous comment). public static final StandardClass GENERIC_FUNCTION = addStandardClass(Symbol.GENERIC_FUNCTION, list(BuiltInClass.FUNCTION, @@ -721,6 +726,13 @@ // There are no inherited slots. SLOT_DEFINITION.setSlotDefinitions(SLOT_DEFINITION.getDirectSlotDefinitions()); + DIRECT_SLOT_DEFINITION.setCPL(DIRECT_SLOT_DEFINITION, SLOT_DEFINITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + DIRECT_SLOT_DEFINITION.finalizeClass(); + EFFECTIVE_SLOT_DEFINITION.setCPL(EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + EFFECTIVE_SLOT_DEFINITION.finalizeClass(); + // STANDARD-METHOD Debug.assertTrue(STANDARD_METHOD.isFinalized()); STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, STANDARD_OBJECT, Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Wed Jun 9 07:27:42 2010 @@ -1138,8 +1138,7 @@ sb.setLength(0); sb.append(readMultipleEscape(rt)); flags = new BitSet(sb.length()); - for (int i = sb.length(); i-- > 0;) - flags.set(i); + flags.set(0, sb.length()); } else if (rt.isInvalid(c)) { rt.checkInvalid(c, this); // Signals a reader-error. } else if (readtableCase == Keyword.UPCASE) { @@ -1180,8 +1179,7 @@ int end = sb.length(); if (flags == null) flags = new BitSet(sb.length()); - for (int i = begin; i < end; i++) - flags.set(i); + flags.set(begin, end); continue; } if (readtableCase == Keyword.UPCASE) Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jun 9 07:27:42 2010 @@ -2943,6 +2943,10 @@ PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST"); public static final Symbol STANDARD_READER_METHOD = PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); + public static final Symbol DIRECT_SLOT_DEFINITION = + PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION"); + public static final Symbol EFFECTIVE_SLOT_DEFINITION = + PACKAGE_MOP.addExternalSymbol("EFFECTIVE-SLOT-DEFINITION"); // Java interface. public static final Symbol JAVA_EXCEPTION = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jun 9 07:27:42 2010 @@ -60,6 +60,8 @@ (defconstant +the-standard-generic-function-class+ (find-class 'standard-generic-function)) (defconstant +the-T-class+ (find-class 'T)) +(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition)) +(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition)) ;; Don't use DEFVAR, because that disallows loading clos.lisp ;; after compiling it: the binding won't get assigned to T anymore @@ -259,40 +261,45 @@ (defun make-initfunction (initform) `(function (lambda () ,initform))) -(defun make-direct-slot-definition (class &key name - (initargs ()) - (initform nil) - (initfunction nil) - (readers ()) - (writers ()) - (allocation :instance) - &allow-other-keys) - (let ((slot (make-slot-definition))) - (set-slot-definition-name slot name) - (set-slot-definition-initargs slot initargs) - (set-slot-definition-initform slot initform) - (set-slot-definition-initfunction slot initfunction) - (set-slot-definition-readers slot readers) - (set-slot-definition-writers slot writers) - (set-slot-definition-allocation slot allocation) - (set-slot-definition-allocation-class slot class) - slot)) - -(defun make-effective-slot-definition (&key name - (initargs ()) - (initform nil) - (initfunction nil) - (allocation :instance) - (allocation-class nil) - &allow-other-keys) - (let ((slot (make-slot-definition))) - (set-slot-definition-name slot name) - (set-slot-definition-initargs slot initargs) - (set-slot-definition-initform slot initform) - (set-slot-definition-initfunction slot initfunction) - (set-slot-definition-allocation slot allocation) - (set-slot-definition-allocation-class slot allocation-class) - slot)) +(defun init-slot-definition (slot &key name + (initargs ()) + (initform nil) + (initfunction nil) + (readers ()) + (writers ()) + (allocation :instance) + (allocation-class nil) + &allow-other-keys) + (set-slot-definition-name slot name) + (set-slot-definition-initargs slot initargs) + (set-slot-definition-initform slot initform) + (set-slot-definition-initfunction slot initfunction) + (set-slot-definition-readers slot readers) + (set-slot-definition-writers slot writers) + (set-slot-definition-allocation slot allocation) + (set-slot-definition-allocation-class slot allocation-class) + slot) + +(defun make-direct-slot-definition (class &rest args) + (let ((slot-class (direct-slot-definition-class class))) + (if (eq slot-class +the-direct-slot-definition-class+) + (let ((slot (make-slot-definition +the-direct-slot-definition-class+))) + (apply #'init-slot-definition slot :allocation-class class args) + slot) + (progn + (let ((slot (apply #'make-instance slot-class :allocation-class class + args))) + slot))))) + +(defun make-effective-slot-definition (class &rest args) + (let ((slot-class (effective-slot-definition-class class))) + (if (eq slot-class +the-effective-slot-definition-class+) + (let ((slot (make-slot-definition +the-effective-slot-definition-class+))) + (apply #'init-slot-definition slot args) + slot) + (progn + (let ((slot (apply #'make-instance slot-class args))) + slot))))) ;;; finalize-inheritance @@ -455,10 +462,10 @@ all-names))) (defun std-compute-effective-slot-definition (class direct-slots) - (declare (ignore class)) (let ((initer (find-if-not #'null direct-slots :key #'%slot-definition-initfunction))) (make-effective-slot-definition + class :name (%slot-definition-name (car direct-slots)) :initform (if initer (%slot-definition-initform initer) @@ -559,6 +566,12 @@ :direct-default-initargs direct-default-initargs) class)) +;(defun convert-to-direct-slot-definition (class canonicalized-slot) +; (apply #'make-instance +; (apply #'direct-slot-definition-class +; class canonicalized-slot) +; canonicalized-slot)) + (defun std-after-initialization-for-classes (class &key direct-superclasses direct-slots direct-default-initargs @@ -1899,7 +1912,17 @@ (redefine-class-forwarder class-direct-default-initargs direct-default-initargs) (redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs) +(defgeneric direct-slot-definition-class (class &rest initargs)) + +(defmethod direct-slot-definition-class ((class class) &rest initargs) + (declare (ignore initargs)) + +the-direct-slot-definition-class+) + +(defgeneric effective-slot-definition-class (class &rest initargs)) +(defmethod effective-slot-definition-class ((class class) &rest initargs) + (declare (ignore initargs)) + +the-effective-slot-definition-class+) (fmakunbound 'documentation) (defgeneric documentation (x doc-type)) @@ -2212,6 +2235,17 @@ (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) (std-shared-initialize instance slot-names initargs)) +(defmethod shared-initialize ((slot slot-definition) slot-names + &rest initargs + &key name initargs initform initfunction + readers writers allocation + &allow-other-keys) + ;;Keyword args are duplicated from init-slot-definition only to have + ;;them checked. + (declare (ignore slot-names)) ;;TODO? + (declare (ignore name initargs initform initfunction readers writers allocation)) + (apply #'init-slot-definition slot initargs)) + ;;; change-class (defgeneric change-class (instance new-class &key)) Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Wed Jun 9 07:27:42 2010 @@ -40,17 +40,33 @@ (defvar *output-file-pathname*) +(defun base-classname (&optional (output-file-pathname *output-file-pathname*)) + (sanitize-class-name (pathname-name output-file-pathname))) + +(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*)) + (%format nil "~A_0" (base-classname output-file-pathname))) + (declaim (ftype (function (t) t) compute-classfile-name)) (defun compute-classfile-name (n &optional (output-file-pathname *output-file-pathname*)) "Computes the name of the class file associated with number `n'." (let ((name - (%format nil "~A-~D" - (substitute #\_ #\. - (pathname-name output-file-pathname)) n))) + (sanitize-class-name + (%format nil "~A_~D" (pathname-name output-file-pathname) n)))) (namestring (merge-pathnames (make-pathname :name name :type "cls") output-file-pathname)))) +(defun sanitize-class-name (name) + (let ((name (copy-seq name))) + (dotimes (i (length name)) + (declare (type fixnum i)) + (when (or (char= (char name i) #\-) + (char= (char name i) #\.) + (char= (char name i) #\Space)) + (setf (char name i) #\_))) + name)) + + (declaim (ftype (function () t) next-classfile-name)) (defun next-classfile-name () (compute-classfile-name (incf *class-number*))) @@ -69,12 +85,14 @@ (declaim (ftype (function (t) t) verify-load)) (defun verify-load (classfile) - (if (> *safety* 0) - (and classfile + #|(if (> *safety* 0) + (and classfile (let ((*load-truename* *output-file-pathname*)) (report-error (load-compiled-function classfile)))) - t)) + t)|# + (declare (ignore classfile)) + t) (declaim (ftype (function (t) t) process-defconstant)) (defun process-defconstant (form) @@ -144,6 +162,7 @@ (parse-body body) (let* ((expr `(lambda ,lambda-list , at decls (block ,block-name , at body))) + (saved-class-number *class-number*) (classfile (next-classfile-name)) (internal-compiler-errors nil) (result (with-open-file @@ -168,7 +187,8 @@ compiled-function) (setf form `(fset ',name - (proxy-preloaded-function ',name ,(file-namestring classfile)) + (sys::get-fasl-function *fasl-loader* + ,saved-class-number) ,*source-position* ',lambda-list ,doc)) @@ -225,6 +245,7 @@ (let ((name (second form))) (eval form) (let* ((expr (function-lambda-expression (macro-function name))) + (saved-class-number *class-number*) (classfile (next-classfile-name))) (with-open-file (f classfile @@ -241,14 +262,10 @@ (if (special-operator-p name) `(put ',name 'macroexpand-macro (make-macro ',name - (proxy-preloaded-function - '(macro-function ,name) - ,(file-namestring classfile)))) + (sys::get-fasl-function *fasl-loader* ,saved-class-number))) `(fset ',name (make-macro ',name - (proxy-preloaded-function - '(macro-function ,name) - ,(file-namestring classfile))) + (sys::get-fasl-function *fasl-loader* ,saved-class-number)) ,*source-position* ',(third form))))))))) (DEFTYPE @@ -348,8 +365,12 @@ ;; to load the compiled functions. Note that this trickery ;; was already used in verify-load before I used it, ;; however, binding *load-truename* isn't fully compliant, I think. - (let ((*load-truename* *output-file-pathname*)) - (when compile-time-too + (when compile-time-too + (let ((*load-truename* *output-file-pathname*) + (*fasl-loader* (make-fasl-class-loader + *class-number* + (concatenate 'string "org.armedbear.lisp." (base-classname)) + nil))) (eval form)))) (declaim (ftype (function (t) t) convert-ensure-method)) @@ -366,7 +387,8 @@ (eq (%car function-form) 'FUNCTION)) (let ((lambda-expression (cadr function-form))) (jvm::with-saved-compiler-policy - (let* ((classfile (next-classfile-name)) + (let* ((saved-class-number *class-number*) + (classfile (next-classfile-name)) (result (with-open-file (f classfile @@ -379,7 +401,8 @@ (declare (ignore result)) (cond (compiled-function (setf (getf tail key) - `(load-compiled-function ,(file-namestring classfile)))) + `(sys::get-fasl-function *fasl-loader* ,saved-class-number))) +;; `(load-compiled-function ,(file-namestring classfile)))) (t ;; FIXME This should be a warning or error of some sort... (format *error-output* "; Unable to compile method~%"))))))))) @@ -412,6 +435,7 @@ (return-from convert-toplevel-form (precompiler:precompile-form form nil *compile-file-environment*))) (let* ((expr `(lambda () ,form)) + (saved-class-number *class-number*) (classfile (next-classfile-name)) (result (with-open-file @@ -425,7 +449,7 @@ (declare (ignore result)) (setf form (if compiled-function - `(funcall (load-compiled-function ,(file-namestring classfile))) + `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number)) (precompiler:precompile-form form nil *compile-file-environment*))))) @@ -572,25 +596,22 @@ (write (list 'setq '*source* *compile-file-truename*) :stream out) (%stream-terpri out) - ;; Note: Beyond this point, you can't use DUMP-FORM, - ;; because the list of uninterned symbols has been fixed now. - (when *fasl-uninterned-symbols* - (write (list 'setq '*fasl-uninterned-symbols* - (coerce (mapcar #'car - (nreverse *fasl-uninterned-symbols*)) - 'vector)) - :stream out)) - (%stream-terpri out) - ;; we work with a fixed variable name here to work around the - ;; lack of availability of the circle reader in the fasl reader - ;; but it's a toplevel form anyway - (write `(dotimes (i ,*class-number*) - (function-preload - (%format nil "~A-~D.cls" - ,(substitute #\_ #\. (pathname-name output-file)) - (1+ i)))) - :stream out - :circle t) + ;; Note: Beyond this point, you can't use DUMP-FORM, + ;; because the list of uninterned symbols has been fixed now. + (when *fasl-uninterned-symbols* + (write (list 'setq '*fasl-uninterned-symbols* + (coerce (mapcar #'car + (nreverse *fasl-uninterned-symbols*)) + 'vector)) + :stream out)) + (%stream-terpri out) + + (when (> *class-number* 0) + (generate-loader-function) + (write (list 'setq '*fasl-loader* + `(sys::make-fasl-class-loader + ,*class-number* + ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) (%stream-terpri out)) @@ -609,7 +630,11 @@ (zipfile (namestring (merge-pathnames (make-pathname :type type) output-file))) - (pathnames ())) + (pathnames nil) + (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls") + output-file)))) + (when (probe-file fasl-loader) + (push fasl-loader pathnames)) (dotimes (i *class-number*) (let* ((pathname (compute-classfile-name (1+ i)))) (when (probe-file pathname) @@ -632,6 +657,55 @@ (namestring output-file) elapsed)))) (values (truename output-file) warnings-p failure-p))) +(defmacro ncase (expr min max &rest clauses) + "A CASE where all test clauses are numbers ranging from a minimum to a maximum." + ;;Expr is subject to multiple evaluation, but since we only use ncase for + ;;fn-index below, let's ignore it. + (let* ((half (floor (/ (- max min) 2))) + (middle (+ min half))) + (if (> (- max min) 10) + `(if (< ,expr ,middle) + (ncase ,expr ,min ,middle ,@(subseq clauses 0 half)) + (ncase ,expr ,middle ,max ,@(subseq clauses half))) + `(case ,expr , at clauses)))) + +(defun generate-loader-function () + (let* ((basename (base-classname)) + (expr `(lambda (fasl-loader fn-index) + (identity fasl-loader) ;;to avoid unused arg + (ncase fn-index 0 ,(1- *class-number*) + ,@(loop + :for i :from 1 :to *class-number* + :collect + (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i))) + `(,(1- i) + (jvm::with-inline-code () + (jvm::emit 'jvm::aload 1) + (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" + nil jvm::+java-object+) + (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") + (jvm::emit 'jvm::dup) + (jvm::emit-push-constant-int ,(1- i)) + (jvm::emit 'jvm::new ,class) + (jvm::emit 'jvm::dup) + (jvm::emit-invokespecial-init ,class '()) + (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction" + (list "I" jvm::+lisp-object+) jvm::+lisp-object+) + (jvm::emit 'jvm::pop)) + t)))))) + (classname (fasl-loader-classname)) + (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") + *output-file-pathname*)))) + (jvm::with-saved-compiler-policy + (jvm::with-file-compilation + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (jvm:compile-defun nil expr nil + classfile f nil)))))) + (defun compile-file-if-needed (input-file &rest allargs &key force-compile &allow-other-keys) (setf input-file (truename input-file)) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Jun 9 07:27:42 2010 @@ -1298,7 +1298,7 @@ (format t "; inlining call to local function ~S~%" op))) (return-from p1-function-call (let ((*inline-declarations* - (remove op *inline-declarations* :key #'car))) + (remove op *inline-declarations* :key #'car :test #'equal))) (p1 expansion)))))) ;; FIXME @@ -1432,7 +1432,8 @@ (TRULY-THE p1-truly-the) (UNWIND-PROTECT p1-unwind-protect) (THREADS:SYNCHRONIZED-ON - p1-threads-synchronized-on))) + p1-threads-synchronized-on) + (JVM::WITH-INLINE-CODE identity))) (install-p1-handler (%car pair) (%cadr pair)))) (initialize-p1-handlers) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Jun 9 07:27:42 2010 @@ -198,6 +198,8 @@ (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF)) n))) +(defconstant +fasl-loader-class+ + "org/armedbear/lisp/FaslClassLoader") (defconstant +java-string+ "Ljava/lang/String;") (defconstant +java-object+ "Ljava/lang/Object;") (defconstant +lisp-class+ "org/armedbear/lisp/Lisp") @@ -2267,12 +2269,22 @@ local-function *declared-functions* ht g (setf g (symbol-name (gensym "LFUN"))) (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function))) + (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname))) (*code* *static-code*)) ;; fixme *declare-inline* - (declare-field g +lisp-object+ +field-access-default+) - (emit 'ldc (pool-string (file-namestring pathname))) - (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" - (list +java-string+) +lisp-object+) + (declare-field g +lisp-object+ +field-access-private+) + (emit 'new class-name) + (emit 'dup) + (emit-invokespecial-init class-name '()) + + ;(emit 'ldc (pool-string (pathname-name pathname))) + ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction" + ;(list +java-string+) +lisp-object+) + +; (emit 'ldc (pool-string (file-namestring pathname))) + +; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" +; (list +java-string+) +lisp-object+) (emit 'putstatic *this-class* g +lisp-object+) (setf *static-code* *code*) (setf (gethash local-function ht) g)))) @@ -2421,10 +2433,6 @@ (packagep form) (pathnamep form) (vectorp form) - (stringp form) - (packagep form) - (pathnamep form) - (vectorp form) (structure-object-p form) (standard-object-p form) (java:java-object-p form)) @@ -5098,7 +5106,8 @@ (local-function-function local-function))))) (emit 'getstatic *this-class* g +lisp-object+))))) ; Stack: template-function - ((member name *functions-defined-in-current-file* :test #'equal) + ((and (member name *functions-defined-in-current-file* :test #'equal) + (not (notinline-p name))) (emit 'getstatic *this-class* (declare-setf-function name) +lisp-object+) (emit-move-from-stack target)) @@ -7548,6 +7557,32 @@ ;; delay resolving the method to run-time; it's unavailable now (compile-function-call form target representation)))) +#|(defknown p2-java-jcall (t t t) t) +(define-inlined-function p2-java-jcall (form target representation) + ((and (> *speed* *safety*) + (< 1 (length form)) + (eq 'jmethod (car (cadr form))) + (every #'stringp (cdr (cadr form))))) + (let ((m (ignore-errors (eval (cadr form))))) + (if m + (let ((must-clear-values nil) + (arg-types (raw-arg-types (jmethod-params m)))) + (declare (type boolean must-clear-values)) + (dolist (arg (cddr form)) + (compile-form arg 'stack nil) + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t)))) + (when must-clear-values + (emit-clear-values)) + (dotimes (i (jarray-length raw-arg-types)) + (push (jarray-ref raw-arg-types i) arg-types)) + (emit-invokevirtual (jclass-name (jmethod-declaring-class m)) + (jmethod-name m) + (nreverse arg-types) + (jmethod-return-type m))) + ;; delay resolving the method to run-time; it's unavailable now + (compile-function-call form target representation))))|# (defknown p2-char= (t t t) t) (defun p2-char= (form target representation) @@ -8224,6 +8259,13 @@ (setf (method-handlers execute-method) (nreverse *handlers*))) t) +(defun p2-with-inline-code (form target representation) + ;;form = (with-inline-code (&optional target-var repr-var) ...body...) + (destructuring-bind (&optional target-var repr-var) (cadr form) + (eval `(let (,@(when target-var `((,target-var ,target))) + ,@(when repr-var `((,repr-var ,representation)))) + ,@(cddr form))))) + (defun compile-1 (compiland stream) (let ((*all-variables* nil) (*closure-variables* nil) @@ -8516,6 +8558,7 @@ (install-p2-handler 'java:jclass 'p2-java-jclass) (install-p2-handler 'java:jconstructor 'p2-java-jconstructor) (install-p2-handler 'java:jmethod 'p2-java-jmethod) +; (install-p2-handler 'java:jcall 'p2-java-jcall) (install-p2-handler 'char= 'p2-char=) (install-p2-handler 'characterp 'p2-characterp) (install-p2-handler 'coerce-to-function 'p2-coerce-to-function) @@ -8600,6 +8643,7 @@ (install-p2-handler 'vector-push-extend 'p2-vector-push-extend) (install-p2-handler 'write-8-bits 'p2-write-8-bits) (install-p2-handler 'zerop 'p2-zerop) + (install-p2-handler 'with-inline-code 'p2-with-inline-code) t) (initialize-p2-handlers) Modified: trunk/abcl/src/org/armedbear/lisp/disassemble.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/disassemble.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/disassemble.lisp Wed Jun 9 07:27:42 2010 @@ -47,14 +47,15 @@ (when (functionp function) (unless (compiled-function-p function) (setf function (compile nil function))) - (when (getf (function-plist function) 'class-bytes) - (with-input-from-string - (stream (disassemble-class-bytes (getf (function-plist function) 'class-bytes))) - (loop - (let ((line (read-line stream nil))) - (unless line (return)) - (write-string "; ") - (write-string line) - (terpri)))) - (return-from disassemble))) - (%format t "; Disassembly is not available.~%"))) + (let ((class-bytes (function-class-bytes function))) + (when class-bytes + (with-input-from-string + (stream (disassemble-class-bytes class-bytes)) + (loop + (let ((line (read-line stream nil))) + (unless line (return)) + (write-string "; ") + (write-string line) + (terpri)))) + (return-from disassemble))) + (%format t "; Disassembly is not available.~%")))) Modified: trunk/abcl/src/org/armedbear/lisp/gui.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gui.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/gui.lisp Wed Jun 9 07:27:42 2010 @@ -1,5 +1,7 @@ (in-package :extensions) +(require :java) + (defvar *gui-backend* :swing) (defun init-gui () Modified: trunk/abcl/src/org/armedbear/lisp/load.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/load.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/load.lisp Wed Jun 9 07:27:42 2010 @@ -38,10 +38,11 @@ (if-does-not-exist t) (external-format :default)) (declare (ignore external-format)) ; FIXME - (%load (if (streamp filespec) - filespec - (merge-pathnames (pathname filespec))) - verbose print if-does-not-exist)) + (let (*fasl-loader*) + (%load (if (streamp filespec) + filespec + (merge-pathnames (pathname filespec))) + verbose print if-does-not-exist))) (defun load-returning-last-result (filespec &key @@ -50,7 +51,8 @@ (if-does-not-exist t) (external-format :default)) (declare (ignore external-format)) ; FIXME - (%load-returning-last-result (if (streamp filespec) - filespec - (merge-pathnames (pathname filespec))) - verbose print if-does-not-exist)) \ No newline at end of file + (let (*fasl-loader*) + (%load-returning-last-result (if (streamp filespec) + filespec + (merge-pathnames (pathname filespec))) + verbose print if-does-not-exist))) \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed Jun 9 07:27:42 2010 @@ -32,13 +32,10 @@ (in-package "SYSTEM") -(export '(*inline-declarations* - process-optimization-declarations +(export '(process-optimization-declarations inline-p notinline-p inline-expansion expand-inline *defined-functions* *undefined-functions* note-name-defined)) -(defvar *inline-declarations* nil) - (declaim (ftype (function (t) t) process-optimization-declarations)) (defun process-optimization-declarations (forms) (dolist (form forms) @@ -86,7 +83,7 @@ (declaim (ftype (function (t) t) inline-p)) (defun inline-p (name) (declare (optimize speed)) - (let ((entry (assoc name *inline-declarations*))) + (let ((entry (assoc name *inline-declarations* :test #'equal))) (if entry (eq (cdr entry) 'INLINE) (and (symbolp name) (eq (get name '%inline) 'INLINE))))) @@ -94,7 +91,7 @@ (declaim (ftype (function (t) t) notinline-p)) (defun notinline-p (name) (declare (optimize speed)) - (let ((entry (assoc name *inline-declarations*))) + (let ((entry (assoc name *inline-declarations* :test #'equal))) (if entry (eq (cdr entry) 'NOTINLINE) (and (symbolp name) (eq (get name '%inline) 'NOTINLINE))))) @@ -961,7 +958,8 @@ (symbol-name symbol)) 'precompiler)))) (unless (and handler (fboundp handler)) - (error "No handler for ~S." symbol)) + (error "No handler for ~S." (let ((*package* (find-package :keyword))) + (format nil "~S" symbol)))) (setf (get symbol 'precompile-handler) handler))) (defun install-handlers () @@ -1024,7 +1022,9 @@ (TRULY-THE precompile-truly-the) (THREADS:SYNCHRONIZED-ON - precompile-threads-synchronized-on))) + precompile-threads-synchronized-on) + + (JVM::WITH-INLINE-CODE precompile-identity))) (install-handler (first pair) (second pair)))) (install-handlers) Modified: trunk/abcl/src/org/armedbear/lisp/proclaim.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/proclaim.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/proclaim.lisp Wed Jun 9 07:27:42 2010 @@ -31,7 +31,7 @@ (in-package #:system) -(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type)) +(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type *inline-declarations*)) (defmacro declaim (&rest decls) `(eval-when (:compile-toplevel :load-toplevel :execute) @@ -43,6 +43,7 @@ :format-control "The symbol ~S cannot be both the name of a type and the name of a declaration." :format-arguments (list name))) +(defvar *inline-declarations* nil) (defvar *declaration-types* (make-hash-table :test 'eq)) ;; "A symbol cannot be both the name of a type and the name of a declaration. @@ -91,8 +92,9 @@ (apply 'proclaim-type (cdr declaration-specifier))) ((INLINE NOTINLINE) (dolist (name (cdr declaration-specifier)) - (when (symbolp name) ; FIXME Need to support non-symbol function names. - (setf (get name '%inline) (car declaration-specifier))))) + (if (symbolp name) + (setf (get name '%inline) (car declaration-specifier)) + (push (cons name (car declaration-specifier)) *inline-declarations*)))) (DECLARATION (dolist (name (cdr declaration-specifier)) (when (or (get name 'deftype-definition) Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Wed Jun 9 07:27:42 2010 @@ -278,7 +278,6 @@ return new AbclScriptEngineFactory(); } - @Override public T getInterface(Class clasz) { try { return getInterface(eval("(cl:find-package '#:ABCL-SCRIPT-USER)"), clasz); @@ -288,14 +287,12 @@ } @SuppressWarnings("unchecked") - @Override public T getInterface(Object thiz, Class clasz) { Symbol s = findSymbol("jmake-proxy", "JAVA"); JavaObject iface = new JavaObject(clasz); return (T) ((JavaObject) s.execute(iface, (LispObject) thiz)).javaInstance(); } - @Override public Object invokeFunction(String name, Object... args) throws ScriptException, NoSuchMethodException { Symbol s; if(name.indexOf(':') >= 0) { @@ -320,7 +317,6 @@ } } - @Override public Object invokeMethod(Object thiz, String name, Object... args) throws ScriptException, NoSuchMethodException { throw new UnsupportedOperationException("Common Lisp does not have methods in the Java sense. Use invokeFunction instead."); } Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Wed Jun 9 07:27:42 2010 @@ -31,104 +31,92 @@ private static final AbclScriptEngine THE_ONLY_ONE_ENGINE = new AbclScriptEngine(); - @Override - public String getEngineName() { - return "ABCL Script"; - } - - @Override - public String getEngineVersion() { - return "0.1"; - } - - @Override - public List getExtensions() { - List extensions = new ArrayList(1); - extensions.add("lisp"); - return Collections.unmodifiableList(extensions); - } - - @Override - public String getLanguageName() { - return "ANSI Common Lisp"; - } - - @Override - public String getLanguageVersion() { - return "ANSI X3.226:1994"; - } - - public static String escape(String raw) { - StringBuilder sb = new StringBuilder(); - int len = raw.length(); - char c; - for(int i = 0; i < len; ++i) { - c = raw.charAt(i); - if(c != '"') { - sb.append(c); - } else { - sb.append("\\\""); - } - } - return sb.toString(); + public String getEngineName() { + return "ABCL Script"; + } + + public String getEngineVersion() { + return "0.1"; + } + + public List getExtensions() { + List extensions = new ArrayList(1); + extensions.add("lisp"); + return Collections.unmodifiableList(extensions); + } + + public String getLanguageName() { + return "ANSI Common Lisp"; + } + + public String getLanguageVersion() { + return "ANSI X3.226:1994"; + } + + public static String escape(String raw) { + StringBuilder sb = new StringBuilder(); + int len = raw.length(); + char c; + for(int i = 0; i < len; ++i) { + c = raw.charAt(i); + if(c != '"') { + sb.append(c); + } else { + sb.append("\\\""); + } } + return sb.toString(); + } - @Override - public String getMethodCallSyntax(String obj, String method, String... args) { - StringBuilder sb = new StringBuilder(); - sb.append("(jcall \""); - sb.append(method); - sb.append("\" "); - sb.append(obj); - for(String arg : args) { - sb.append(" "); - sb.append(arg); - } - sb.append(")"); - return sb.toString(); - } - - @Override - public List getMimeTypes() { - return Collections.unmodifiableList(new ArrayList()); - } - - @Override - public List getNames() { - List names = new ArrayList(1); - names.add("ABCL"); - names.add("cl"); - names.add("Lisp"); - names.add("Common Lisp"); - return Collections.unmodifiableList(names); - } - - @Override - public String getOutputStatement(String str) { - return "(cl:print \"" + str + "\")"; - } - - @Override - public Object getParameter(String key) { - // TODO Auto-generated method stub - return null; - } - - @Override - public String getProgram(String... statements) { - StringBuilder sb = new StringBuilder(); - sb.append("(cl:progn"); - for(String stmt : statements) { - sb.append("\n\t"); - sb.append(stmt); - } - sb.append(")"); - return sb.toString(); - } - - @Override - public ScriptEngine getScriptEngine() { - return THE_ONLY_ONE_ENGINE; - } + public String getMethodCallSyntax(String obj, String method, String... args) { + StringBuilder sb = new StringBuilder(); + sb.append("(jcall \""); + sb.append(method); + sb.append("\" "); + sb.append(obj); + for(String arg : args) { + sb.append(" "); + sb.append(arg); + } + sb.append(")"); + return sb.toString(); + } + + public List getMimeTypes() { + return Collections.unmodifiableList(new ArrayList()); + } + + public List getNames() { + List names = new ArrayList(1); + names.add("ABCL"); + names.add("cl"); + names.add("Lisp"); + names.add("Common Lisp"); + return Collections.unmodifiableList(names); + } + + public String getOutputStatement(String str) { + return "(cl:print \"" + str + "\")"; + } + + public Object getParameter(String key) { + // TODO Auto-generated method stub + return null; + } + + public String getProgram(String... statements) { + StringBuilder sb = new StringBuilder(); + sb.append("(cl:progn"); + for(String stmt : statements) { + sb.append("\n\t"); + sb.append(stmt); + } + sb.append(")"); + return sb.toString(); + } + + public ScriptEngine getScriptEngine() { + return THE_ONLY_ONE_ENGINE; + } } From mevenson at common-lisp.net Thu Jun 10 09:24:21 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 10 Jun 2010 05:24:21 -0400 Subject: [armedbear-cvs] r12750 - trunk/abcl Message-ID: Author: mevenson Date: Thu Jun 10 05:24:20 2010 New Revision: 12750 Log: Include "examples/**" is source release. Rported and Patched by Mario Lang. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Thu Jun 10 05:24:20 2010 @@ -464,6 +464,8 @@ + + From mevenson at common-lisp.net Thu Jun 10 09:29:34 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 10 Jun 2010 05:29:34 -0400 Subject: [armedbear-cvs] r12751 - branches/0.20.x/abcl Message-ID: Author: mevenson Date: Thu Jun 10 05:29:33 2010 New Revision: 12751 Log: Backport r12750: Include "examples/**" in source release. Modified: branches/0.20.x/abcl/build.xml Modified: branches/0.20.x/abcl/build.xml ============================================================================== --- branches/0.20.x/abcl/build.xml (original) +++ branches/0.20.x/abcl/build.xml Thu Jun 10 05:29:33 2010 @@ -464,6 +464,8 @@ + + From astalla at common-lisp.net Sun Jun 13 21:33:06 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 13 Jun 2010 17:33:06 -0400 Subject: [armedbear-cvs] r12752 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Jun 13 17:33:04 2010 New Revision: 12752 Log: Progress towards custom slot definition support: use of generic slot-definition-* Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Sun Jun 13 17:33:04 2010 @@ -90,9 +90,9 @@ slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE; } - public static SlotDefinition checkSlotDefinition(LispObject obj) { - if (obj instanceof SlotDefinition) return (SlotDefinition)obj; - return (SlotDefinition)type_error(obj, Symbol.SLOT_DEFINITION); + public static StandardObject checkSlotDefinition(LispObject obj) { + if (obj instanceof StandardObject) return (StandardObject)obj; + return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION); } public final LispObject getName() Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jun 13 17:33:04 2010 @@ -60,6 +60,7 @@ (defconstant +the-standard-generic-function-class+ (find-class 'standard-generic-function)) (defconstant +the-T-class+ (find-class 'T)) +(defconstant +the-slot-definition-class+ (find-class 'slot-definition)) (defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition)) (defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition)) @@ -261,6 +262,21 @@ (defun make-initfunction (initform) `(function (lambda () ,initform))) +(defun slot-definition-allocation (slot-definition) + (%slot-definition-allocation slot-definition)) + +(defun slot-definition-initargs (slot-definition) + (%slot-definition-initargs slot-definition)) + +(defun slot-definition-initform (slot-definition) + (%slot-definition-initform slot-definition)) + +(defun slot-definition-initfunction (slot-definition) + (%slot-definition-initfunction slot-definition)) + +(defun slot-definition-name (slot-definition) + (%slot-definition-name slot-definition)) + (defun init-slot-definition (slot &key name (initargs ()) (initform nil) @@ -327,18 +343,18 @@ (instance-slots '()) (shared-slots '())) (dolist (slot (class-slots class)) - (case (%slot-definition-allocation slot) + (case (slot-definition-allocation slot) (:instance (set-slot-definition-location slot length) (incf length) - (push (%slot-definition-name slot) instance-slots)) + (push (slot-definition-name slot) instance-slots)) (:class (unless (%slot-definition-location slot) (let ((allocation-class (%slot-definition-allocation-class slot))) (set-slot-definition-location slot (if (eq allocation-class class) - (cons (%slot-definition-name slot) +slot-unbound+) - (slot-location allocation-class (%slot-definition-name slot)))))) + (cons (slot-definition-name slot) +slot-unbound+) + (slot-location allocation-class (slot-definition-name slot)))))) (push (%slot-definition-location slot) shared-slots)))) (when old-layout ;; Redefined class: initialize added shared slots. @@ -346,8 +362,8 @@ (let* ((slot-name (car location)) (old-location (layout-slot-location old-layout slot-name))) (unless old-location - (let* ((slot-definition (find slot-name (class-slots class) :key #'%slot-definition-name)) - (initfunction (%slot-definition-initfunction slot-definition))) + (let* ((slot-definition (find slot-name (class-slots class) :key #'slot-definition-name)) + (initfunction (slot-definition-initfunction slot-definition))) (when initfunction (setf (cdr location) (funcall initfunction)))))))) (setf (class-layout class) @@ -449,7 +465,7 @@ (let* ((all-slots (mapappend #'class-direct-slots (class-precedence-list class))) (all-names (remove-duplicates - (mapcar #'%slot-definition-name all-slots)))) + (mapcar #'slot-definition-name all-slots)))) (mapcar #'(lambda (name) (funcall (if (eq (class-of class) +the-standard-class+) @@ -457,26 +473,26 @@ #'compute-effective-slot-definition) class (remove name all-slots - :key #'%slot-definition-name + :key #'slot-definition-name :test-not #'eq))) all-names))) (defun std-compute-effective-slot-definition (class direct-slots) (let ((initer (find-if-not #'null direct-slots - :key #'%slot-definition-initfunction))) + :key #'slot-definition-initfunction))) (make-effective-slot-definition class - :name (%slot-definition-name (car direct-slots)) + :name (slot-definition-name (car direct-slots)) :initform (if initer - (%slot-definition-initform initer) + (slot-definition-initform initer) nil) :initfunction (if initer - (%slot-definition-initfunction initer) + (slot-definition-initfunction initer) nil) :initargs (remove-duplicates - (mapappend #'%slot-definition-initargs + (mapappend #'slot-definition-initargs direct-slots)) - :allocation (%slot-definition-allocation (car direct-slots)) + :allocation (slot-definition-allocation (car direct-slots)) :allocation-class (%slot-definition-allocation-class (car direct-slots))))) ;;; Standard instance slot access @@ -487,7 +503,7 @@ (defun find-slot-definition (class slot-name) (dolist (slot (class-slots class) nil) - (when (eq slot-name (%slot-definition-name slot)) + (when (eq slot-name (slot-definition-name slot)) (return slot)))) (defun slot-location (class slot-name) @@ -537,7 +553,7 @@ (defun std-slot-exists-p (instance slot-name) (not (null (find slot-name (class-slots (class-of instance)) - :key #'%slot-definition-name)))) + :key #'slot-definition-name)))) (defun slot-exists-p (object slot-name) (if (eq (class-of (class-of object)) +the-standard-class+) @@ -545,7 +561,7 @@ (slot-exists-p-using-class (class-of object) object slot-name))) (defun instance-slot-p (slot) - (eq (%slot-definition-allocation slot) :instance)) + (eq (slot-definition-allocation slot) :instance)) (defun make-instance-standard-class (metaclass &rest initargs @@ -587,9 +603,9 @@ (setf (class-direct-slots class) slots) (dolist (direct-slot slots) (dolist (reader (%slot-definition-readers direct-slot)) - (add-reader-method class reader (%slot-definition-name direct-slot))) + (add-reader-method class reader (slot-definition-name direct-slot))) (dolist (writer (%slot-definition-writers direct-slot)) - (add-writer-method class writer (%slot-definition-name direct-slot))))) + (add-writer-method class writer (slot-definition-name direct-slot))))) (setf (class-direct-default-initargs class) direct-default-initargs) (funcall (if (eq (class-of class) +the-standard-class+) #'std-finalize-inheritance @@ -2160,7 +2176,7 @@ (defun valid-initarg-p (initarg slots) (dolist (slot slots nil) - (let ((valid-initargs (%slot-definition-initargs slot))) + (let ((valid-initargs (slot-definition-initargs slot))) (when (memq initarg valid-initargs) (return t))))) @@ -2217,13 +2233,13 @@ :format-control "Invalid initarg ~S." :format-arguments (list initarg)))) (dolist (slot (class-slots (class-of instance))) - (let ((slot-name (%slot-definition-name slot))) + (let ((slot-name (slot-definition-name slot))) (multiple-value-bind (init-key init-value foundp) - (get-properties all-keys (%slot-definition-initargs slot)) + (get-properties all-keys (slot-definition-initargs slot)) (if foundp (setf (std-slot-value instance slot-name) init-value) (unless (std-slot-boundp instance slot-name) - (let ((initfunction (%slot-definition-initfunction slot))) + (let ((initfunction (slot-definition-initfunction slot))) (when (and initfunction (or (eq slot-names t) (memq slot-name slot-names))) (setf (std-slot-value instance slot-name) @@ -2260,8 +2276,8 @@ ;; unbound." (dolist (new-slot new-slots) (when (instance-slot-p new-slot) - (let* ((slot-name (%slot-definition-name new-slot)) - (old-slot (find slot-name old-slots :key #'%slot-definition-name))) + (let* ((slot-name (slot-definition-name new-slot)) + (old-slot (find slot-name old-slots :key #'slot-definition-name))) ;; "The values of slots specified as shared in the class CFROM and as ;; local in the class CTO are retained." (when (and old-slot (slot-boundp old-instance slot-name)) @@ -2284,7 +2300,7 @@ (let ((added-slots (remove-if #'(lambda (slot-name) (slot-exists-p old slot-name)) - (mapcar #'%slot-definition-name + (mapcar #'slot-definition-name (class-slots (class-of new)))))) (check-initargs new added-slots initargs) (apply #'shared-initialize new added-slots initargs))) @@ -2375,7 +2391,10 @@ ;;; Slot definition accessors -(export '(slot-definition-allocation +(mapcar (lambda (sym) + (fmakunbound sym) ;;we need to redefine them as GFs + (export sym)) + '(slot-definition-allocation slot-definition-initargs slot-definition-initform slot-definition-initfunction @@ -2383,23 +2402,53 @@ (defgeneric slot-definition-allocation (slot-definition) (:method ((slot-definition slot-definition)) - (%slot-definition-allocation slot-definition))) + (let ((cl (class-of slot-definition))) + (case cl + ((+the-slot-definition-class+ + +the-direct-slot-definition-class+ + +the-effective-slot-definition-class+) + (%slot-definition-allocation slot-definition)) + (t (slot-value slot-definition 'sys::allocation)))))) (defgeneric slot-definition-initargs (slot-definition) (:method ((slot-definition slot-definition)) - (%slot-definition-initargs slot-definition))) + (let ((cl (class-of slot-definition))) + (case cl + ((+the-slot-definition-class+ + +the-direct-slot-definition-class+ + +the-effective-slot-definition-class+) + (%slot-definition-initargs slot-definition)) + (t (slot-value slot-definition 'sys::initargs)))))) (defgeneric slot-definition-initform (slot-definition) (:method ((slot-definition slot-definition)) - (%slot-definition-initform slot-definition))) + (let ((cl (class-of slot-definition))) + (case cl + ((+the-slot-definition-class+ + +the-direct-slot-definition-class+ + +the-effective-slot-definition-class+) + (%slot-definition-initform slot-definition)) + (t (slot-value slot-definition 'sys::initform)))))) (defgeneric slot-definition-initfunction (slot-definition) (:method ((slot-definition slot-definition)) - (%slot-definition-initfunction slot-definition))) + (let ((cl (class-of slot-definition))) + (case cl + ((+the-slot-definition-class+ + +the-direct-slot-definition-class+ + +the-effective-slot-definition-class+) + (%slot-definition-initfunction slot-definition)) + (t (slot-value slot-definition 'sys::initfunction)))))) (defgeneric slot-definition-name (slot-definition) (:method ((slot-definition slot-definition)) - (%slot-definition-name slot-definition))) + (let ((cl (class-of slot-definition))) + (case cl + ((+the-slot-definition-class+ + +the-direct-slot-definition-class+ + +the-effective-slot-definition-class+) + (%slot-definition-name slot-definition)) + (t (slot-value slot-definition 'sys::name)))))) ;;; No %slot-definition-type. From astalla at common-lisp.net Mon Jun 14 21:02:35 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 14 Jun 2010 17:02:35 -0400 Subject: [armedbear-cvs] r12753 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Jun 14 17:02:34 2010 New Revision: 12753 Log: Progress towards support for custom slot definitions: use of generic (setf slot-definition-*), bugfixes Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jun 14 17:02:34 2010 @@ -265,18 +265,33 @@ (defun slot-definition-allocation (slot-definition) (%slot-definition-allocation slot-definition)) +(defun (setf slot-definition-allocation) (value slot-definition) + (set-slot-definition-allocation slot-definition value)) + (defun slot-definition-initargs (slot-definition) (%slot-definition-initargs slot-definition)) +(defun (setf slot-definition-initargs) (value slot-definition) + (set-slot-definition-initargs slot-definition value)) + (defun slot-definition-initform (slot-definition) (%slot-definition-initform slot-definition)) +(defun (setf slot-definition-initform) (value slot-definition) + (set-slot-definition-initform slot-definition value)) + (defun slot-definition-initfunction (slot-definition) (%slot-definition-initfunction slot-definition)) +(defun (setf slot-definition-initfunction) (value slot-definition) + (set-slot-definition-initfunction slot-definition value)) + (defun slot-definition-name (slot-definition) (%slot-definition-name slot-definition)) +(defun (setf slot-definition-name) (value slot-definition) + (set-slot-definition-name slot-definition value)) + (defun init-slot-definition (slot &key name (initargs ()) (initform nil) @@ -285,14 +300,14 @@ (writers ()) (allocation :instance) (allocation-class nil) - &allow-other-keys) - (set-slot-definition-name slot name) - (set-slot-definition-initargs slot initargs) - (set-slot-definition-initform slot initform) - (set-slot-definition-initfunction slot initfunction) + &allow-other-keys) + (setf (slot-definition-name slot) name) + (setf (slot-definition-initargs slot) initargs) + (setf (slot-definition-initform slot) initform) + (setf (slot-definition-initfunction slot) initfunction) (set-slot-definition-readers slot readers) (set-slot-definition-writers slot writers) - (set-slot-definition-allocation slot allocation) + (setf (slot-definition-allocation slot) allocation) (set-slot-definition-allocation-class slot allocation-class) slot) @@ -2071,13 +2086,23 @@ (defmethod slot-value-using-class ((class standard-class) instance slot-name) (std-slot-value instance slot-name)) +(defmethod slot-value-using-class ((class structure-class) instance slot-name) + (std-slot-value instance slot-name)) + (defgeneric (setf slot-value-using-class) (new-value class instance slot-name)) + (defmethod (setf slot-value-using-class) (new-value (class standard-class) instance slot-name) (setf (std-slot-value instance slot-name) new-value)) +(defmethod (setf slot-value-using-class) (new-value + (class structure-class) + instance + slot-name) + (setf (std-slot-value instance slot-name) new-value)) + (defgeneric slot-exists-p-using-class (class instance slot-name)) (defmethod slot-exists-p-using-class (class instance slot-name) @@ -2252,7 +2277,7 @@ (std-shared-initialize instance slot-names initargs)) (defmethod shared-initialize ((slot slot-definition) slot-names - &rest initargs + &rest args &key name initargs initform initfunction readers writers allocation &allow-other-keys) @@ -2260,7 +2285,7 @@ ;;them checked. (declare (ignore slot-names)) ;;TODO? (declare (ignore name initargs initform initfunction readers writers allocation)) - (apply #'init-slot-definition slot initargs)) + (apply #'init-slot-definition slot args)) ;;; change-class @@ -2391,64 +2416,84 @@ ;;; Slot definition accessors -(mapcar (lambda (sym) - (fmakunbound sym) ;;we need to redefine them as GFs - (export sym)) +(map nil (lambda (sym) + (fmakunbound sym) ;;we need to redefine them as GFs + (fmakunbound `(setf ,sym)) + (export sym)) '(slot-definition-allocation slot-definition-initargs slot-definition-initform slot-definition-initfunction slot-definition-name)) +(defmacro slot-definition-dispatch (slot-definition std-form generic-form) + `(let (($cl (class-of ,slot-definition))) + (case $cl + ((+the-slot-definition-class+ + +the-direct-slot-definition-class+ + +the-effective-slot-definition-class+) + ,std-form) + (t ,generic-form)))) + (defgeneric slot-definition-allocation (slot-definition) (:method ((slot-definition slot-definition)) - (let ((cl (class-of slot-definition))) - (case cl - ((+the-slot-definition-class+ - +the-direct-slot-definition-class+ - +the-effective-slot-definition-class+) - (%slot-definition-allocation slot-definition)) - (t (slot-value slot-definition 'sys::allocation)))))) + (slot-definition-dispatch slot-definition + (%slot-definition-allocation slot-definition) + (slot-value slot-definition 'sys::allocation)))) + +(defgeneric (setf slot-definition-allocation) (value slot-definition) + (:method (value (slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (set-slot-definition-allocation slot-definition value) + (setf (slot-value slot-definition 'sys::allocation) value)))) (defgeneric slot-definition-initargs (slot-definition) (:method ((slot-definition slot-definition)) - (let ((cl (class-of slot-definition))) - (case cl - ((+the-slot-definition-class+ - +the-direct-slot-definition-class+ - +the-effective-slot-definition-class+) - (%slot-definition-initargs slot-definition)) - (t (slot-value slot-definition 'sys::initargs)))))) + (slot-definition-dispatch slot-definition + (%slot-definition-initargs slot-definition) + (slot-value slot-definition 'sys::initargs)))) + +(defgeneric (setf slot-definition-initargs) (value slot-definition) + (:method (value (slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (set-slot-definition-initargs slot-definition value) + (setf (slot-value slot-definition 'sys::initargs) value)))) (defgeneric slot-definition-initform (slot-definition) (:method ((slot-definition slot-definition)) - (let ((cl (class-of slot-definition))) - (case cl - ((+the-slot-definition-class+ - +the-direct-slot-definition-class+ - +the-effective-slot-definition-class+) - (%slot-definition-initform slot-definition)) - (t (slot-value slot-definition 'sys::initform)))))) + (slot-definition-dispatch slot-definition + (%slot-definition-initform slot-definition) + (slot-value slot-definition 'sys::initform)))) + +(defgeneric (setf slot-definition-initform) (value slot-definition) + (:method (value (slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (set-slot-definition-initform slot-definition value) + (setf (slot-value slot-definition 'sys::initform) value)))) (defgeneric slot-definition-initfunction (slot-definition) (:method ((slot-definition slot-definition)) - (let ((cl (class-of slot-definition))) - (case cl - ((+the-slot-definition-class+ - +the-direct-slot-definition-class+ - +the-effective-slot-definition-class+) - (%slot-definition-initfunction slot-definition)) - (t (slot-value slot-definition 'sys::initfunction)))))) + (slot-definition-dispatch slot-definition + (%slot-definition-initfunction slot-definition) + (slot-value slot-definition 'sys::initfunction)))) + +(defgeneric (setf slot-definition-initfunction) (value slot-definition) + (:method (value (slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (set-slot-definition-initfunction slot-definition value) + (setf (slot-value slot-definition 'sys::initfunction) value)))) (defgeneric slot-definition-name (slot-definition) (:method ((slot-definition slot-definition)) - (let ((cl (class-of slot-definition))) - (case cl - ((+the-slot-definition-class+ - +the-direct-slot-definition-class+ - +the-effective-slot-definition-class+) - (%slot-definition-name slot-definition)) - (t (slot-value slot-definition 'sys::name)))))) + (slot-definition-dispatch slot-definition + (%slot-definition-name slot-definition) + (slot-value slot-definition 'sys::name)))) + +(defgeneric (setf slot-definition-name) (value slot-definition) + (:method (value (slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (set-slot-definition-name slot-definition value) + (setf (slot-value slot-definition 'sys::name) value)))) ;;; No %slot-definition-type. From astalla at common-lisp.net Tue Jun 15 22:43:59 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 15 Jun 2010 18:43:59 -0400 Subject: [armedbear-cvs] r12754 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Jun 15 18:43:56 2010 New Revision: 12754 Log: Don't bind *load-truename* to NIL while loading FASLs, or SLIME compilation breaks. Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Tue Jun 15 18:43:56 2010 @@ -70,15 +70,7 @@ public byte[] getFunctionClassBytes(String name) { Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); - final LispThread thread = LispThread.currentThread(); - SpecialBindingsMark mark = thread.markSpecialBindings(); - try { - //thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, NIL); - thread.bindSpecial(Symbol.LOAD_TRUENAME, NIL); - return readFunctionBytes(pathname); - } finally { - thread.resetSpecialBindings(mark); - } + return readFunctionBytes(pathname); } public byte[] getFunctionClassBytes(Class functionClass) { From astalla at common-lisp.net Wed Jun 16 18:18:50 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 16 Jun 2010 14:18:50 -0400 Subject: [armedbear-cvs] r12755 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Jun 16 14:18:49 2010 New Revision: 12755 Log: CL:STRING on Java objects calls toString() on them. Patch by Mario Lang. 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 (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Wed Jun 16 14:18:49 2010 @@ -108,6 +108,13 @@ return super.typep(type); } + + @Override + public LispObject STRING() + { + return new SimpleString(obj != null? obj.toString(): "null"); + } + public final Object getObject() { return obj; From astalla at common-lisp.net Thu Jun 17 20:14:12 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 17 Jun 2010 16:14:12 -0400 Subject: [armedbear-cvs] r12756 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu Jun 17 16:14:10 2010 New Revision: 12756 Log: Simple slot-* support for structures. Modified: trunk/abcl/src/org/armedbear/lisp/StructureObject.java trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StructureObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StructureObject.java Thu Jun 17 16:14:10 2010 @@ -153,6 +153,49 @@ return structureClass; } + protected int getSlotIndex(LispObject slotName) { + LispObject effectiveSlots = structureClass.getSlotDefinitions(); + LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray(); + for (int i = 0; i < slots.length; i++) { + SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i]; + LispObject candidateSlotName = slotDefinition.AREF(1); + if(slotName == candidateSlotName) { + return i; + } + } + return -1; + } + + @Override + public LispObject SLOT_VALUE(LispObject slotName) + { + LispObject value; + final int index = getSlotIndex(slotName); + if (index >= 0) { + value = slots[index]; + } else { + value = UNBOUND_VALUE; + value = Symbol.SLOT_UNBOUND.execute(structureClass, this, slotName); + LispThread.currentThread()._values = null; + } + return value; + } + + public void setSlotValue(LispObject slotName, LispObject newValue) { + final int index = getSlotIndex(slotName); + if (index >= 0) { + slots[index] = newValue; + } else { + LispObject[] args = new LispObject[5]; + args[0] = structureClass; + args[1] = this; + args[2] = slotName; + args[3] = Symbol.SETF; + args[4] = newValue; + Symbol.SLOT_MISSING.execute(args); + } + } + @Override public LispObject getParts() { Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Jun 17 16:14:10 2010 @@ -123,7 +123,8 @@ mop::ensure-method define-method-combination %defgeneric - canonicalize-direct-superclasses) + canonicalize-direct-superclasses + slot-value slot-makunbound slot-boundp) "clos") (export '(ensure-class subclassp %defgeneric canonicalize-direct-superclasses) '#:system) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Jun 17 16:14:10 2010 @@ -53,6 +53,7 @@ (export '(class-precedence-list class-slots)) (defconstant +the-standard-class+ (find-class 'standard-class)) +(defconstant +the-structure-class+ (find-class 'structure-class)) (defconstant +the-standard-object-class+ (find-class 'standard-object)) (defconstant +the-standard-method-class+ (find-class 'standard-method)) (defconstant +the-standard-reader-method-class+ @@ -292,6 +293,24 @@ (defun (setf slot-definition-name) (value slot-definition) (set-slot-definition-name slot-definition value)) +(defun slot-definition-readers (slot-definition) + (%slot-definition-readers slot-definition)) + +(defun (setf slot-definition-readers) (value slot-definition) + (set-slot-definition-readers slot-definition value)) + +(defun slot-definition-writers (slot-definition) + (%slot-definition-writers slot-definition)) + +(defun (setf slot-definition-writers) (value slot-definition) + (set-slot-definition-writers slot-definition value)) + +(defun slot-definition-allocation-class (slot-definition) + (%slot-definition-allocation-class slot-definition)) + +(defun (setf slot-definition-allocation-class) (value slot-definition) + (set-slot-definition-allocation-class slot-definition value)) + (defun init-slot-definition (slot &key name (initargs ()) (initform nil) @@ -305,10 +324,10 @@ (setf (slot-definition-initargs slot) initargs) (setf (slot-definition-initform slot) initform) (setf (slot-definition-initfunction slot) initfunction) - (set-slot-definition-readers slot readers) - (set-slot-definition-writers slot writers) + (setf (slot-definition-readers slot) readers) + (setf (slot-definition-writers slot) writers) (setf (slot-definition-allocation slot) allocation) - (set-slot-definition-allocation-class slot allocation-class) + (setf (slot-definition-allocation-class slot) allocation-class) slot) (defun make-direct-slot-definition (class &rest args) @@ -532,14 +551,16 @@ (and layout (layout-slot-location layout slot-name)))) (defun slot-value (object slot-name) - (if (eq (class-of (class-of object)) +the-standard-class+) + (if (or (eq (class-of (class-of object)) +the-standard-class+) + (eq (class-of (class-of object)) +the-structure-class+)) (std-slot-value object slot-name) (slot-value-using-class (class-of object) object slot-name))) (defsetf std-slot-value set-std-slot-value) (defun %set-slot-value (object slot-name new-value) - (if (eq (class-of (class-of object)) +the-standard-class+) + (if (or (eq (class-of (class-of object)) +the-standard-class+) + (eq (class-of (class-of object)) +the-structure-class+)) (setf (std-slot-value object slot-name) new-value) (set-slot-value-using-class new-value (class-of object) object slot-name))) @@ -2120,12 +2141,21 @@ (defgeneric slot-boundp-using-class (class instance slot-name)) (defmethod slot-boundp-using-class ((class standard-class) instance slot-name) (std-slot-boundp instance slot-name)) +(defmethod slot-boundp-using-class ((class structure-class) instance slot-name) + "Structure slots can't be unbound, so this method always returns T." + (declare (ignore class instance slot-name)) + t) (defgeneric slot-makunbound-using-class (class instance slot-name)) (defmethod slot-makunbound-using-class ((class standard-class) instance slot-name) (std-slot-makunbound instance slot-name)) +(defmethod slot-makunbound-using-class ((class structure-class) + instance + slot-name) + (declare (ignore class instance slot-name)) + (error "Structure slots can't be unbound")) (defgeneric slot-missing (class instance slot-name operation &optional new-value)) @@ -2424,7 +2454,10 @@ slot-definition-initargs slot-definition-initform slot-definition-initfunction - slot-definition-name)) + slot-definition-name + slot-definition-readers + slot-definition-writers + slot-definition-allocation-class)) (defmacro slot-definition-dispatch (slot-definition std-form generic-form) `(let (($cl (class-of ,slot-definition))) @@ -2495,6 +2528,42 @@ (set-slot-definition-name slot-definition value) (setf (slot-value slot-definition 'sys::name) value)))) +(defgeneric slot-definition-readers (slot-definition) + (:method ((slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (%slot-definition-readers slot-definition) + (slot-value slot-definition 'sys::readers)))) + +(defgeneric (setf slot-definition-readers) (value slot-definition) + (:method (value (slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (set-slot-definition-readers slot-definition value) + (setf (slot-value slot-definition 'sys::readers) value)))) + +(defgeneric slot-definition-writers (slot-definition) + (:method ((slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (%slot-definition-writers slot-definition) + (slot-value slot-definition 'sys::writers)))) + +(defgeneric (setf slot-definition-writers) (value slot-definition) + (:method (value (slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (set-slot-definition-writers slot-definition value) + (setf (slot-value slot-definition 'sys::writers) value)))) + +(defgeneric slot-definition-allocation-class (slot-definition) + (:method ((slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (%slot-definition-allocation-class slot-definition) + (slot-value slot-definition 'sys::allocation-class)))) + +(defgeneric (setf slot-definition-allocation-class) (value slot-definition) + (:method (value (slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (set-slot-definition-allocation-class slot-definition value) + (setf (slot-value slot-definition 'sys::allocation-class) value)))) + ;;; No %slot-definition-type. From astalla at common-lisp.net Fri Jun 18 22:48:31 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 18 Jun 2010 18:48:31 -0400 Subject: [armedbear-cvs] r12757 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jun 18 18:48:30 2010 New Revision: 12757 Log: User-defined slot definition support: fixed slot-definition initialization. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jun 18 18:48:30 2010 @@ -163,7 +163,8 @@ (documentation nil) (readers ()) (writers ()) - (other-options ())) + (other-options ()) + (non-std-options ())) (do ((olist (cdr spec) (cddr olist))) ((null olist)) (case (car olist) @@ -208,9 +209,11 @@ (push-on-end (cadr olist) readers) (push-on-end `(setf ,(cadr olist)) writers)) (t - (error 'program-error - "invalid initialization argument ~S for slot named ~S" - (car olist) name)))) + (push-on-end (car olist) non-std-options) + (push-on-end (cadr olist) non-std-options)))) +; (error 'program-error +; "invalid initialization argument ~S for slot named ~S" +; (car olist) name)) `(list :name ',name ,@(when initfunction @@ -219,7 +222,8 @@ ,@(when initargs `(:initargs ',initargs)) ,@(when readers `(:readers ',readers)) ,@(when writers `(:writers ',writers)) - , at other-options)))) + , at other-options + , at non-std-options)))) (defun maybe-note-name-defined (name) (when (fboundp 'note-name-defined) @@ -266,48 +270,56 @@ (defun slot-definition-allocation (slot-definition) (%slot-definition-allocation slot-definition)) +(declaim (notinline (setf slot-definition-allocation))) (defun (setf slot-definition-allocation) (value slot-definition) (set-slot-definition-allocation slot-definition value)) (defun slot-definition-initargs (slot-definition) (%slot-definition-initargs slot-definition)) +(declaim (notinline (setf slot-definition-initargs))) (defun (setf slot-definition-initargs) (value slot-definition) (set-slot-definition-initargs slot-definition value)) (defun slot-definition-initform (slot-definition) (%slot-definition-initform slot-definition)) +(declaim (notinline (setf slot-definition-initform))) (defun (setf slot-definition-initform) (value slot-definition) (set-slot-definition-initform slot-definition value)) (defun slot-definition-initfunction (slot-definition) (%slot-definition-initfunction slot-definition)) +(declaim (notinline (setf slot-definition-initfunction))) (defun (setf slot-definition-initfunction) (value slot-definition) (set-slot-definition-initfunction slot-definition value)) (defun slot-definition-name (slot-definition) (%slot-definition-name slot-definition)) +(declaim (notinline (setf slot-definition-name))) (defun (setf slot-definition-name) (value slot-definition) (set-slot-definition-name slot-definition value)) (defun slot-definition-readers (slot-definition) (%slot-definition-readers slot-definition)) +(declaim (notinline (setf slot-definition-readers))) (defun (setf slot-definition-readers) (value slot-definition) (set-slot-definition-readers slot-definition value)) (defun slot-definition-writers (slot-definition) (%slot-definition-writers slot-definition)) +(declaim (notinline (setf slot-definition-writers))) (defun (setf slot-definition-writers) (value slot-definition) (set-slot-definition-writers slot-definition value)) (defun slot-definition-allocation-class (slot-definition) (%slot-definition-allocation-class slot-definition)) +(declaim (notinline (setf slot-definition-allocation-class))) (defun (setf slot-definition-allocation-class) (value slot-definition) (set-slot-definition-allocation-class slot-definition value)) @@ -384,7 +396,7 @@ (push (slot-definition-name slot) instance-slots)) (:class (unless (%slot-definition-location slot) - (let ((allocation-class (%slot-definition-allocation-class slot))) + (let ((allocation-class (slot-definition-allocation-class slot))) (set-slot-definition-location slot (if (eq allocation-class class) (cons (slot-definition-name slot) +slot-unbound+) @@ -396,7 +408,7 @@ (let* ((slot-name (car location)) (old-location (layout-slot-location old-layout slot-name))) (unless old-location - (let* ((slot-definition (find slot-name (class-slots class) :key #'slot-definition-name)) + (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name)) (initfunction (slot-definition-initfunction slot-definition))) (when initfunction (setf (cdr location) (funcall initfunction)))))))) @@ -499,7 +511,7 @@ (let* ((all-slots (mapappend #'class-direct-slots (class-precedence-list class))) (all-names (remove-duplicates - (mapcar #'slot-definition-name all-slots)))) + (mapcar 'slot-definition-name all-slots)))) (mapcar #'(lambda (name) (funcall (if (eq (class-of class) +the-standard-class+) @@ -507,13 +519,13 @@ #'compute-effective-slot-definition) class (remove name all-slots - :key #'slot-definition-name + :key 'slot-definition-name :test-not #'eq))) all-names))) (defun std-compute-effective-slot-definition (class direct-slots) (let ((initer (find-if-not #'null direct-slots - :key #'slot-definition-initfunction))) + :key 'slot-definition-initfunction))) (make-effective-slot-definition class :name (slot-definition-name (car direct-slots)) @@ -524,10 +536,14 @@ (slot-definition-initfunction initer) nil) :initargs (remove-duplicates - (mapappend #'slot-definition-initargs + (mapappend 'slot-definition-initargs direct-slots)) :allocation (slot-definition-allocation (car direct-slots)) - :allocation-class (%slot-definition-allocation-class (car direct-slots))))) + :allocation-class (when (slot-boundp (car direct-slots) + 'sys::allocation-class) + ;;for some classes created in Java + ;;(e.g. SimpleCondition) this slot is unbound + (slot-definition-allocation-class (car direct-slots)))))) ;;; Standard instance slot access @@ -589,7 +605,7 @@ (defun std-slot-exists-p (instance slot-name) (not (null (find slot-name (class-slots (class-of instance)) - :key #'slot-definition-name)))) + :key 'slot-definition-name)))) (defun slot-exists-p (object slot-name) (if (eq (class-of (class-of object)) +the-standard-class+) @@ -638,9 +654,9 @@ direct-slots))) (setf (class-direct-slots class) slots) (dolist (direct-slot slots) - (dolist (reader (%slot-definition-readers direct-slot)) + (dolist (reader (slot-definition-readers direct-slot)) (add-reader-method class reader (slot-definition-name direct-slot))) - (dolist (writer (%slot-definition-writers direct-slot)) + (dolist (writer (slot-definition-writers direct-slot)) (add-writer-method class writer (slot-definition-name direct-slot))))) (setf (class-direct-default-initargs class) direct-default-initargs) (funcall (if (eq (class-of class) +the-standard-class+) @@ -2315,7 +2331,10 @@ ;;them checked. (declare (ignore slot-names)) ;;TODO? (declare (ignore name initargs initform initfunction readers writers allocation)) - (apply #'init-slot-definition slot args)) + ;;For built-in slots + (apply #'init-slot-definition slot args) + ;;For user-defined slots + (call-next-method)) ;;; change-class @@ -2332,7 +2351,7 @@ (dolist (new-slot new-slots) (when (instance-slot-p new-slot) (let* ((slot-name (slot-definition-name new-slot)) - (old-slot (find slot-name old-slots :key #'slot-definition-name))) + (old-slot (find slot-name old-slots :key 'slot-definition-name))) ;; "The values of slots specified as shared in the class CFROM and as ;; local in the class CTO are retained." (when (and old-slot (slot-boundp old-instance slot-name)) @@ -2355,7 +2374,7 @@ (let ((added-slots (remove-if #'(lambda (slot-name) (slot-exists-p old slot-name)) - (mapcar #'slot-definition-name + (mapcar 'slot-definition-name (class-slots (class-of new)))))) (check-initargs new added-slots initargs) (apply #'shared-initialize new added-slots initargs))) From astalla at common-lisp.net Fri Jun 18 23:15:53 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 18 Jun 2010 19:15:53 -0400 Subject: [armedbear-cvs] r12758 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jun 18 19:15:52 2010 New Revision: 12758 Log: Custom slot definition: slot-location managed like the other slot properties. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jun 18 19:15:52 2010 @@ -323,6 +323,13 @@ (defun (setf slot-definition-allocation-class) (value slot-definition) (set-slot-definition-allocation-class slot-definition value)) +(defun slot-definition-location (slot-definition) + (%slot-definition-location slot-definition)) + +(declaim (notinline (setf slot-definition-location-class))) +(defun (setf slot-definition-location) (value slot-definition) + (set-slot-definition-location slot-definition value)) + (defun init-slot-definition (slot &key name (initargs ()) (initform nil) @@ -391,17 +398,17 @@ (dolist (slot (class-slots class)) (case (slot-definition-allocation slot) (:instance - (set-slot-definition-location slot length) + (setf (slot-definition-location slot) length) (incf length) (push (slot-definition-name slot) instance-slots)) (:class - (unless (%slot-definition-location slot) + (unless (slot-definition-location slot) (let ((allocation-class (slot-definition-allocation-class slot))) - (set-slot-definition-location slot - (if (eq allocation-class class) - (cons (slot-definition-name slot) +slot-unbound+) - (slot-location allocation-class (slot-definition-name slot)))))) - (push (%slot-definition-location slot) shared-slots)))) + (setf (slot-definition-location slot) + (if (eq allocation-class class) + (cons (slot-definition-name slot) +slot-unbound+) + (slot-location allocation-class (slot-definition-name slot)))))) + (push (slot-definition-location slot) shared-slots)))) (when old-layout ;; Redefined class: initialize added shared slots. (dolist (location shared-slots) @@ -559,7 +566,7 @@ (defun slot-location (class slot-name) (let ((slot (find-slot-definition class slot-name))) (if slot - (%slot-definition-location slot) + (slot-definition-location slot) nil))) (defun instance-slot-location (instance slot-name) @@ -2583,6 +2590,18 @@ (set-slot-definition-allocation-class slot-definition value) (setf (slot-value slot-definition 'sys::allocation-class) value)))) +(defgeneric slot-definition-location (slot-definition) + (:method ((slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (%slot-definition-location slot-definition) + (slot-value slot-definition 'sys::location)))) + +(defgeneric (setf slot-definition-location) (value slot-definition) + (:method (value (slot-definition slot-definition)) + (slot-definition-dispatch slot-definition + (set-slot-definition-location slot-definition value) + (setf (slot-value slot-definition 'sys::location) value)))) + ;;; No %slot-definition-type. From vvoutilainen at common-lisp.net Sun Jun 20 17:51:30 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 20 Jun 2010 13:51:30 -0400 Subject: [armedbear-cvs] r12759 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: vvoutilainen Date: Sun Jun 20 13:51:29 2010 New Revision: 12759 Log: Mark functions final where applicable. Modified: trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java Modified: trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java Sun Jun 20 13:51:29 2010 @@ -87,38 +87,38 @@ /** Change the Charset used to decode bytes from the input stream * into characters. */ - public void setCharset(Charset cs) { + public final void setCharset(Charset cs) { this.cd = cs.newDecoder(); this.ce = cs.newEncoder(); } /** Get the Charset used to decode bytes from the input stream. */ - public Charset getCharset() { + public final Charset getCharset() { return this.cd.charset(); } @Override - public void close() throws IOException { + public final void close() throws IOException { stream.close(); } @Override - public void mark(int readAheadLimit) throws IOException { + public final void mark(int readAheadLimit) throws IOException { throw new IOException("mark/reset not supported."); } @Override - public boolean markSupported() { + public final boolean markSupported() { return false; } @Override - public boolean ready() throws IOException { + public final boolean ready() throws IOException { return stream.available() != 0 || bbuf.remaining() != 0; } @Override - public void reset() throws IOException { + public final void reset() throws IOException { throw new IOException("reset/mark not supported."); } @@ -128,7 +128,7 @@ * Returns the number of characters actually skipped */ @Override - public long skip(long n) throws IOException { + public final long skip(long n) throws IOException { char[] cbuf = new char[(int)Math.min(4096, n)]; long m = n; @@ -151,7 +151,7 @@ * */ @Override - public void unread(int c) throws IOException { + public final void unread(int c) throws IOException { char[] ch = Character.toChars(c); unread(ch, 0, ch.length); } @@ -163,7 +163,7 @@ * the stream again, using a different charset. */ @Override - public void unread(char[] cbuf, int off, int len) throws IOException { + public final void unread(char[] cbuf, int off, int len) throws IOException { ByteBuffer tb = // temp buffer ce.encode(CharBuffer.wrap(cbuf, off, len)); @@ -189,7 +189,7 @@ } @Override - public void unread(char[] cbuf) throws IOException { + public final void unread(char[] cbuf) throws IOException { unread(cbuf, 0, cbuf.length); } @@ -220,7 +220,7 @@ } @Override - public int read() throws IOException { + public final int read() throws IOException { // read the first UTF-16 character char[] ch = new char[1]; @@ -244,13 +244,13 @@ } @Override - public int read(char[] cbuf, int off, int len) throws IOException { + public final int read(char[] cbuf, int off, int len) throws IOException { CharBuffer cb = CharBuffer.wrap(cbuf, off, len); return read(cb); } @Override - public int read(CharBuffer cb) throws IOException { + public final int read(CharBuffer cb) throws IOException { int len = cb.remaining(); boolean notEof = true; boolean forceRead = false; @@ -277,7 +277,7 @@ } @Override - public int read(char[] cbuf) throws IOException { + public final int read(char[] cbuf) throws IOException { return read(cbuf, 0, cbuf.length); } From ehuelsmann at common-lisp.net Sun Jun 20 20:38:09 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 20 Jun 2010 16:38:09 -0400 Subject: [armedbear-cvs] r12760 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jun 20 16:38:08 2010 New Revision: 12760 Log: Remove separate FaslVersionMismatch exception in favor of raising a lispy error directly. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sun Jun 20 16:38:08 2010 @@ -198,12 +198,6 @@ new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER), verbose, print, false, returnLastResult); } - catch (FaslVersionMismatch e) { - StringBuilder sb = - new StringBuilder("Incorrect fasl version: "); - sb.append(truename); - return error(new SimpleError(sb.toString())); - } finally { if (in != null) { try { @@ -328,11 +322,6 @@ Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER); return loadFileFromStream(pathname, truename, stream, verbose, print, auto); - } catch (FaslVersionMismatch e) { - StringBuilder sb = - new StringBuilder("; Incorrect fasl version: "); - sb.append(truename); - System.err.println(sb.toString()); } finally { thread.resetSpecialBindings(mark); try { @@ -407,16 +396,21 @@ public LispObject execute(LispObject first, LispObject second) { + final LispThread thread = LispThread.currentThread(); if (first == Keyword.VERSION) { if (second.eql(_FASL_VERSION_.getSymbolValue())) { // OK - final LispThread thread = LispThread.currentThread(); thread.bindSpecial(_FASL_UNINTERNED_SYMBOLS_, NIL); thread.bindSpecial(_SOURCE_, NIL); return faslLoadStream(thread); } } - throw new FaslVersionMismatch(second); + return + error(new SimpleError("FASL version mismatch; found '" + + second.writeToString() + "' but expected '" + + _FASL_VERSION_.getSymbolValue().writeToString() + + "' in " + + Symbol.LOAD_PATHNAME.symbolValue(thread).writeToString())); } } @@ -700,19 +694,4 @@ false); } } - - private static class FaslVersionMismatch extends Error - { - private final LispObject version; - - public FaslVersionMismatch(LispObject version) - { - this.version = version; - } - - public LispObject getVersion() - { - return version; - } - } } From ehuelsmann at common-lisp.net Mon Jun 21 20:42:54 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 21 Jun 2010 16:42:54 -0400 Subject: [armedbear-cvs] r12761 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jun 21 16:42:53 2010 New Revision: 12761 Log: Fix compilation of toplevel MACROLET forms. 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 (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Jun 21 16:42:53 2010 @@ -176,7 +176,7 @@ (push e internal-compiler-errors) (continue)))) (report-error - (jvm:compile-defun name expr nil + (jvm:compile-defun name expr *compile-file-environment* classfile f nil))))) (compiled-function (if (not internal-compiler-errors) (verify-load classfile) @@ -253,7 +253,8 @@ :element-type '(unsigned-byte 8) :if-exists :supersede) (ignore-errors - (jvm:compile-defun nil expr nil classfile f nil))) + (jvm:compile-defun nil expr *compile-file-environment* + classfile f nil))) (if (null (verify-load classfile)) ;; FIXME error or warning (format *error-output* "; Unable to compile macro ~A~%" name) @@ -396,7 +397,9 @@ :element-type '(unsigned-byte 8) :if-exists :supersede) (report-error - (jvm:compile-defun nil lambda-expression nil classfile f nil)))) + (jvm:compile-defun nil lambda-expression + *compile-file-environment* + classfile f nil)))) (compiled-function (verify-load classfile))) (declare (ignore result)) (cond (compiled-function @@ -443,8 +446,8 @@ :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) - (report-error (jvm:compile-defun nil expr nil classfile - f declare-inline)))) + (report-error (jvm:compile-defun nil expr *compile-file-environment* + classfile f declare-inline)))) (compiled-function (verify-load classfile))) (declare (ignore result)) (setf form @@ -703,7 +706,7 @@ :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) - (jvm:compile-defun nil expr nil + (jvm:compile-defun nil expr *compile-file-environment* classfile f nil)))))) (defun compile-file-if-needed (input-file &rest allargs &key force-compile From ehuelsmann at common-lisp.net Mon Jun 21 21:04:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 21 Jun 2010 17:04:35 -0400 Subject: [armedbear-cvs] r12762 - branches/generic-class-file Message-ID: Author: ehuelsmann Date: Mon Jun 21 17:04:34 2010 New Revision: 12762 Log: Create generic class file generator branch. Added: branches/generic-class-file/ - copied from r12761, /trunk/ From ehuelsmann at common-lisp.net Mon Jun 21 21:55:38 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 21 Jun 2010 17:55:38 -0400 Subject: [armedbear-cvs] r12763 - branches/generic-class-file/abcl Message-ID: Author: ehuelsmann Date: Mon Jun 21 17:55:32 2010 New Revision: 12763 Log: Add README.BRANCH: Goal filled in; status to be completed. Actual code still to be committed. Added: branches/generic-class-file/abcl/README.BRANCH Added: branches/generic-class-file/abcl/README.BRANCH ============================================================================== --- (empty file) +++ branches/generic-class-file/abcl/README.BRANCH Mon Jun 21 17:55:32 2010 @@ -0,0 +1,45 @@ + +This file describes the goals and current status of the +branch it pertains to. In this case the generic-class-file branch. + + +Goal(s) +======= + +The goal of the branch is to replace the existing class file writer which +is restricted to writing 2 methods in a class file with an extremely +restricted set of signatures. + +The new writer will allow any number of methods with no limitation on the +signatures to be used. This allows a number of things impossible today: + + 1. Eliminating the external dependency of 'runtime-class.lisp' on ASM + 2. Moving initialization of 'final static' fields to the '' + to make 100% sure they get initialized exactly once + 3. Using the Java-paradigm of having multiple methods with different + numbers of parameters to fill in default values + +--------------- example to go with item (3) +final public LispObject execute() { + return execute(); +} + +final public LispObject execute(LispObject arg1) { + return execute(arg1, ); +} + +final public LispObject execute(LispObject arg1, LispObject arg2) { + ... do actual work ...; +} +--------------- end of example + + + + +Status +====== + +The replacement code is located in the java-class-file.lisp file. + +The rest of the status is still to be described. + From ehuelsmann at common-lisp.net Mon Jun 21 21:58:30 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 21 Jun 2010 17:58:30 -0400 Subject: [armedbear-cvs] r12764 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jun 21 17:58:29 2010 New Revision: 12764 Log: Work-in-progress commit: saving current state; no real functional changes. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp Mon Jun 21 17:58:29 2010 @@ -97,6 +97,7 @@ (load (do-compile "precompiler.lisp")) (load (do-compile "compiler-pass1.lisp")) (load (do-compile "compiler-pass2.lisp")) + (load (do-compile "jvm-class-file.lisp")) (load (do-compile "jvm.lisp")) (load (do-compile "source-transform.lisp")) (load (do-compile "compiler-macro.lisp")) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Jun 21 17:58:29 2010 @@ -1751,10 +1751,9 @@ name-index descriptor-index) -(defstruct (java-method (:conc-name method-) (:constructor %make-method)) - access-flags - name - descriptor +(defstruct (java-method (:include method) + (:conc-name method-) + (:constructor %make-method)) name-index descriptor-index max-stack @@ -4905,7 +4904,7 @@ (defmacro with-temp-class-file (pathname class-file lambda-list &body body) `(let* ((,pathname (make-temp-file)) (,class-file (make-class-file :pathname ,pathname - :lambda-list ,lambda-list))) + :lambda-list ,lambda-list))) (unwind-protect (progn , at body) (delete-file pathname)))) Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp Mon Jun 21 17:58:29 2010 @@ -45,6 +45,7 @@ (require "KNOWN-SYMBOLS") (require "DUMP-FORM") (require "OPCODES") + (require "JVM-CLASS-FILE") (require "JAVA") (require "COMPILER-PASS1") (require "COMPILER-PASS2")) @@ -85,17 +86,14 @@ (defvar *externalized-objects* nil) (defvar *declared-functions* nil) -(defstruct (abcl-class-file (:constructor %make-abcl-class-file)) +(defstruct (abcl-class-file (:include class-file) + (:constructor %make-abcl-class-file)) pathname ; pathname of output file lambda-name - class - superclass lambda-list ; as advertised pool (pool-count 1) (pool-entries (make-hash-table :test #'equal)) - fields - methods static-code objects ;; an alist of externalized objects and their field names (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions From mevenson at common-lisp.net Fri Jun 25 10:46:09 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 25 Jun 2010 06:46:09 -0400 Subject: [armedbear-cvs] r12765 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jun 25 06:46:06 2010 New Revision: 12765 Log: Update to ASDF-2.003 with local patches. Local patches differentiate output location by FASL and Java version. 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 (original) +++ trunk/abcl/doc/asdf/asdf.texinfo Fri Jun 25 06:46:06 2010 @@ -170,11 +170,9 @@ the ASDF internals and how to extend ASDF. @emph{Nota Bene}: -We are preparing for a release of ASDF 2, hopefully for May 2010, -which will have version 2.000 and later. -Current releases, in the 1.700 series and beyond, -should be considered as release candidates. -We're still working on polishing the code and documentation. +We have released ASDF 2.000 on May 31st 2010. +It hopefully will have been it included +in all CL maintained implementations shortly afterwards. @xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. @@ -241,7 +239,7 @@ then you're using an old version of ASDF (from before 1.635). If it returns @code{NIL} then ASDF is not installed. -If you are running a version older than 1.711, +If you are running a version older than 2.000, we recommend that you load a newer ASDF using the method below. @@ -340,27 +338,28 @@ the authors of that tool should already have configured ASDF. The simplest way to add a path to your search path, -say @file{/foo/bar/baz/quux/} +say @file{/home/luser/.asd-link-farm/} is to create the directory @file{~/.config/common-lisp/source-registry.conf.d/} -and there create a file with any name of your choice, -for instance @file{42-bazquux.conf} +and there create a file with any name of your choice but the type @file{conf}, +for instance @file{42-asd-link-farm.conf} containing the line: - at kbd{(:directory "/foo/bar/baz/quux/")} + at kbd{(:directory "/home/luser/.asd-link-farm/")} -If you want all the subdirectories under @file{/foo/bar/baz/} +If you want all the subdirectories under @file{/home/luser/lisp/} to be recursively scanned for @file{.asd} files, instead use: - at kbd{(:tree "/foo/bar/baz/quux/")} + at kbd{(:tree "/home/luser/lisp/")} Note that your Operating System distribution or your system administrator may already have configured system-managed libraries for you. -Also note that when choosing a filename, the convention is to use -the @file{.conf} extension -(and a non-empty extension is required for CLISP compatibility), -and it is customary to start the filename with two digits +The required @file{.conf} extension allows you to have disabled files +or editor backups (ending in @file{~}), and works portably +(for instance, it is a pain to allow both empty and non-empty extension on CLISP). +Excluded are files the name of which start with a @file{.} character. +It is customary to start the filename with two digits that specify the order in which the directories will be scanned. ASDF will automatically read your configuration @@ -485,7 +484,7 @@ to @file{/where/i/want/my/fasls/} is to create the directory @file{~/.config/common-lisp/asdf-output-translations.conf.d/} -and there create a file with any name of your choice, +and there create a file with any name of your choice and the type @file{conf}, for instance @file{42-bazquux.conf} containing the line: @@ -510,11 +509,11 @@ under an implementation-dependent subdirectory of @file{~/.cache/common-lisp/}. @xref{Controlling where ASDF searches for systems}, for full details. - -Also note that when choosing a filename, the convention is to use -the @file{.conf} extension -(and a non-empty extension is required for CLISP compatibility), -and it is customary to start the filename with two digits +The required @file{.conf} extension allows you to have disabled files +or editor backups (ending in @file{~}), and works portably +(for instance, it is a pain to allow both empty and non-empty extension on CLISP). +Excluded are files the name of which start with a @file{.} character. +It is customary to start the filename with two digits that specify the order in which the directories will be scanned. ASDF will automatically read your configuration @@ -535,7 +534,7 @@ each in subtly different and incompatible ways: ASDF-Binary-Locations, cl-launch, common-lisp-controller. ASDF-Binary-Locations is now not needed anymore and should not be used. -cl-launch 2.900 and common-lisp-controller 7.1 have been updated +cl-launch 3.000 and common-lisp-controller 7.2 have been updated to just delegate this functionality to ASDF. @node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top @@ -813,6 +812,7 @@ @code{:my-component-type}, or @code{my-component-type}. @subsection Pathname specifiers + at cindex pathname specifiers A pathname specifier (@code{pathname-specifier}) may be a pathname, a string or a symbol. @@ -845,6 +845,14 @@ and a string @code{"foo/bar.quux"} will be interpreted as the pathname @file{#p"foo/bar.quux"}. +ASDF does not interpret the string @code{".."} to designate the parent +directory. This string will be passed through to the underlying +operating system for interpretation. We @emph{believe} that this will +work on all platforms where ASDF is deployed, but do not guarantee this +behavior. A pathname object with a relative directory component of + at code{:up} or @code{:back} is the only guaranteed way to specify a +parent directory. + If a symbol is given, it will be translated into a string, and downcased in the process. The downcasing of symbols is unconventional, @@ -856,23 +864,26 @@ as argument to @code{make-pathname}, which is reported not to work on some implementations. -Pathnames objects may be given to override the path for a component. +Pathname objects may be given to override the path for a component. Such objects are typically specified using reader macros such as @code{#p} or @code{#.(make-pathname ...)}. -Note however, that @code{#p...} is a short for @code{#.(parse-namestring ...)} -and that the behavior @code{parse-namestring} is completely non-portable, -unless you are using Common Lisp @code{logical-pathname}s. -(@xref{The defsystem grammar,,Warning about logical pathnames}, below.) +Note however, that @code{#p...} is a shorthand for @code{#.(parse-namestring ...)} +and that the behavior of @code{parse-namestring} is completely non-portable, +unless you are using Common Lisp @code{logical-pathname}s +(@pxref{The defsystem grammar,,Warning about logical pathnames}, below). Pathnames made with @code{#.(make-pathname ...)} can usually be done more easily with the string syntax above. The only case that you really need a pathname object is to override the component-type default file type for a given component. -Therefore, it is a rare case that pathname objects should be used at all. +Therefore, pathname objects should only rarely be used. Unhappily, ASDF 1 didn't properly support parsing component names as strings specifying paths with directories, and the cumbersome @code{#.(make-pathname ...)} syntax had to be used. -Note that when specifying pathname objects, no magic interpretation of the pathname -is made depending on the component type. + +Note that when specifying pathname objects, +ASDF does not do any special interpretation of the pathname +influenced by the component type, unlike the procedure for +pathname-specifying strings. On the one hand, you have to be careful to provide a pathname that correctly fulfills whatever constraints are required from that component type (e.g. naming a directory or a file with appropriate type); @@ -881,6 +892,11 @@ @subsection Warning about logical pathnames + at cindex logical pathnames + +We recommend that you not use logical pathnames +in your asdf system definitions at this point, +but logical pathnames @emph{are} supported. To use logical pathnames, you will have to provide a pathname object as a @code{:pathname} specifier @@ -888,24 +904,29 @@ @code{#p"LOGICAL-HOST:absolute;path;to;component.lisp"}. You only have to specify such logical pathname for your system or -some top-level component, as sub-components using the usual string syntax -for names will be properly merged with the pathname of their parent. +some top-level component. Sub-components' relative pathnames, specified +using the string syntax +for names, will be properly merged with the pathnames of their parents. The specification of a logical pathname host however is @emph{not} otherwise directly supported in the ASDF syntax for pathname specifiers as strings. -Logical pathnames are not specifically recommended to newcomers, -but are otherwise supported. -Moreover, the @code{asdf-output-translation} layer will -avoid trying to resolve and translate logical-pathnames, -so you can define yourself what translations you want to use +The @code{asdf-output-translation} layer will +avoid trying to resolve and translate logical-pathnames. +The advantage of this is that you can define yourself what translations you want to use with the logical pathname facility. - -The user of logical pathnames will have to configure logical pathnames himself, -before they may be used, and ASDF provides no specific support for that. +The disadvantage is that if you do not define such translations, any +system that uses logical pathnames will be have differently under +asdf-output-translations than other systems you use. + +If you wish to use logical pathnames you will have to configure the +translations yourself before they may be used. +ASDF currently provides no specific support +for defining logical pathname translations. @subsection Serial dependencies + at cindex serial dependencies If the @code{:serial t} option is specified for a module, ASDF will add dependencies for each each child component, @@ -913,8 +934,8 @@ This is done as if by @code{:depends-on}. @lisp -:components ((:file "a") (:file "b") (:file "c")) :serial t +:components ((:file "a") (:file "b") (:file "c")) @end lisp is equivalent to @@ -1713,23 +1734,26 @@ ;; A directive is one of the following: DIRECTIVE := + ;; INHERITANCE DIRECTIVE: + ;; Your configuration expression MUST contain + ;; exactly one of either of these: + :inherit-configuration | ; splices inherited configuration (often specified last) + :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere) + ;; add a single directory to be scanned (no recursion) (:directory DIRECTORY-PATHNAME-DESIGNATOR) | ;; add a directory hierarchy, recursing but excluding specified patterns (:tree DIRECTORY-PATHNAME-DESIGNATOR) | - ;; override the default defaults for exclusion patterns + ;; override the defaults for exclusion patterns (:exclude PATTERN ...) | + ;; augment the defaults for exclusion patterns + (:also-exclude PATTERN ...) | ;; splice the parsed contents of another config file (:include REGULAR-FILE-PATHNAME-DESIGNATOR) | - ;; Your configuration expression MUST contain - ;; exactly one of either of these: - :inherit-configuration | ; splices contents of inherited configuration - :ignore-inherited-configuration | ; drop contents of inherited configuration - ;; This directive specifies that some default must be spliced. :default-registry @@ -1738,6 +1762,15 @@ of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"} @end example +For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf}, +which is the default place ASDF looks for this configuration, +once contained: + at example +(:source-registry + (:tree "/home/fare/cl/") + :inherit-configuration) + at end example + @section Configuration Directories @@ -1746,7 +1779,7 @@ The files will be sorted by namestring as if by @code{string<} and the lists of directives of these files with be concatenated in order. An implicit @code{:inherit-configuration} will be included -at the end of the list. +at the @emph{end} of the list. This allows for packaging software that has file granularity (e.g. Debian's @code{dpkg} or some future version of @code{clbuild}) @@ -1766,6 +1799,15 @@ (:include "/foo/bar/") @end example +Hence, to achieve the same effect as +my example @file{~/.config/common-lisp/source-registry.conf} above, +I could simply create a file + at file{~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf} +alone in its directory with the following contents: + at example +(:tree "/home/fare/cl/") + at end example + @section Shell-friendly syntax for configuration @@ -1808,9 +1850,14 @@ XCVB currently raised an error. If none is found, the search continues. -Exclude statements specify patterns of subdirectories the systems of which -to ignore. Typically you don't want to use copies of files kept by such +Exclude statements specify patterns of subdirectories +the systems from which to ignore. +Typically you don't want to use copies of files kept by such version control systems as Darcs. +Exclude statements are not propagated to further included or inherited +configuration files or expressions; +instead the defaults are reset around every configuration statement +to the default defaults from @code{asdf::*default-source-registry-exclusions*}. Include statements cause the search to recurse with the path specifications from the file specified. @@ -2057,7 +2104,7 @@ in an easy way with configuration files. Recent versions of same packages use the new @code{asdf-output-translations} API as defined below: - at code{common-lisp-controller} (7.1) and @code{cl-launch} (3.00); + at code{common-lisp-controller} (7.2) and @code{cl-launch} (3.000). @code{ASDF-Binary-Locations} is fully superseded and not to be used anymore. This incompatibility shouldn't inconvenience many people. @@ -2110,13 +2157,14 @@ ;; A directive is one of the following: DIRECTIVE := - ;; include a configuration file or directory - (:include PATHNAME-DESIGNATOR) | - + ;; INHERITANCE DIRECTIVE: ;; Your configuration expression MUST contain ;; exactly one of either of these: - :inherit-configuration | ; splices contents of inherited configuration - :ignore-inherited-configuration | ; drop contents of inherited configuration + :inherit-configuration | ; splices inherited configuration (often specified last) + :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere) + + ;; include a configuration file or directory + (:include PATHNAME-DESIGNATOR) | ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something. :enable-user-cache | @@ -2232,7 +2280,7 @@ The files will be sorted by namestring as if by @code{string<} and the lists of directives of these files with be concatenated in order. An implicit @code{:inherit-configuration} will be included -at the end of the list. +at the @emph{end} of the list. This allows for packaging software that has file granularity (e.g. Debian's @command{dpkg} or some future version of @command{clbuild}) @@ -2494,26 +2542,21 @@ @subsection What are ASDF 1 and ASDF 2? -We are preparing for a release of ASDF 2, -which will have version 2.000 and later. -While the code and documentation are essentially complete -we are still working on polishing them before release. - -Releases in the 1.700 series and beyond -should be considered as release candidates. -For all practical purposes, -ASDF 2 refers to releases later than 1.656, -and ASDF 1 to any release earlier than 1.369 or so. -If your ASDF doesn't have a version, it's old. +On May 31st 2010, we have released ASDF 2. +ASDF 2 refers to release 2.000 and later. +(Releases between 1.656 and 1.728 were development releases for ASDF 2.) +ASDF 1 to any release earlier than 1.369 or so. +If your ASDF doesn't sport a version, it's an old ASDF 1. -ASDF 2 release candidates and beyond will have +ASDF 2 and its release candidates push @code{:asdf2} onto @code{*features*} so that if you are writing ASDF-dependent code you may check for this feature to see if the new API is present. @emph{All} versions of ASDF should have the @code{:asdf} feature. If you are experiencing problems or limitations of any sort with ASDF 1, -we recommend that you should upgrade to ASDF 2 or its latest release candidate. +we recommend that you should upgrade to ASDF 2, +or whatever is the latest release. @subsection ASDF can portably name files in subdirectories @@ -2537,6 +2580,12 @@ @code{asdf-utilities:merge-pathnames*}, @code{asdf::merge-component-name-type}. +On the other hand, there are places where systems used to accept namestrings +where you must now use an explicit pathname object: + at code{(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} +must now be written with the @code{#p} syntax: + at code{(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} + @xref{The defsystem grammar,,Pathname specifiers}. @@ -2635,11 +2684,12 @@ @item The internal test suite used to massively fail on many implementations. While still incomplete, it now fully passes -on all implementations supported by the test suite. +on all implementations supported by the test suite, +except for GCL (due to GCL bugs). @item Support was lacking for some implementations. -ABCL was notably wholly broken. +ABCL and GCL were notably wholly broken. ECL extensions were not integrated in the ASDF release. @item @@ -2660,7 +2710,7 @@ With ASDF 2, we provide a new stable set of working features that everyone can rely on from now on. Use @code{#+asdf2} to detect presence of ASDF 2, - at code{(asdf:version-satisfies (asdf:asdf-version) "1.711")} + at code{(asdf:version-satisfies (asdf:asdf-version) "2.000")} to check the availability of a version no earlier than required. @@ -2733,6 +2783,16 @@ @pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. But thou shall not load ABL on top of ASDF 2. + at item +ASDF pathname designators are now specified in places where they were unspecified, +and a few small adjustments have to be made to some non-portable defsystems. +Notably, in the @code{:pathname} argument to a @code{defsystem} and its components, +a logical pathname (or implementation-dependent hierarchical pathname) +must now be specified with @code{#p} syntax +where the namestring might have previously sufficed; +moreover when evaluation is desired @code{#.} must be used, +where it wasn't necessary in the toplevel @code{:pathname} argument. + @end itemize Other issues include the following: @@ -3089,12 +3149,8 @@ @section Missing bits in implementation -** all of the above - ** reuse the same scratch package whenever a system is reloaded from disk -** rules for system pathname defaulting are not yet implemented properly - ** proclamations probably aren't ** when a system is reloaded with fewer components than it previously had, odd things happen @@ -3103,16 +3159,6 @@ like take the list of kids and @code{setf} the slot to @code{nil}, then transfer children from old to new list as they're found. -** traverse may become a normal function - -If you're defining methods on @code{traverse}, speak up. - - -** a lot of load-op methods can be rewritten to use input-files - -so should be. - - ** (stuff that might happen later) *** Propagation of the @code{:force} option. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Fri Jun 25 06:46:06 2010 @@ -47,30 +47,30 @@ #+xcvb (module ()) -(cl:in-package :cl-user) +(cl:in-package :cl) +(defpackage :asdf-bootstrap (:use :cl)) +(in-package :asdf-bootstrap) -(declaim (optimize (speed 2) (debug 2) (safety 3)) - #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) - -#+ecl (require :cmp) +;; Implementation-dependent tweaks +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults. + #+allegro + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) + #+ecl (require :cmp) + #+gcl + (eval-when (:compile-toplevel :load-toplevel) + (defpackage :asdf-utilities (:use :cl)) + (defpackage :asdf (:use :cl :asdf-utilities)))) ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more at the end of the file. -#+gcl -(eval-when (:compile-toplevel :load-toplevel) - (defpackage :asdf-utilities (:use :cl)) - (defpackage :asdf (:use :cl :asdf-utilities))) - (eval-when (:load-toplevel :compile-toplevel :execute) - #+allegro - (setf excl::*autoload-package-name-alist* - (remove "asdf" excl::*autoload-package-name-alist* - :test 'equalp :key 'car)) - (let* ((asdf-version - ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:1.719" (1+ (length "VERSION")))) + (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate + (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105. (existing-asdf (find-package :asdf)) (vername '#:*asdf-version*) (versym (and existing-asdf @@ -80,7 +80,7 @@ (unless (and existing-asdf already-there) #-gcl (when existing-asdf - (format *error-output* + (format *trace-output* "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" existing-version asdf-version)) (labels @@ -155,13 +155,11 @@ (macrolet ((pkgdcl (name &key nicknames use export redefined-functions unintern fmakunbound shadow) - `(ensure-package - ',name :nicknames ',nicknames :use ',use :export ',export - :shadow ',shadow - :unintern ',(append #-(or gcl ecl) redefined-functions - unintern) - :fmakunbound ',(append #+(or gcl ecl) redefined-functions - fmakunbound)))) + `(ensure-package + ',name :nicknames ',nicknames :use ',use :export ',export + :shadow ',shadow + :unintern ',(append #-(or gcl ecl) redefined-functions unintern) + :fmakunbound ',(append fmakunbound)))) (pkgdcl :asdf-utilities :nicknames (#:asdf-extensions) @@ -290,6 +288,7 @@ #:clear-output-translations #:ensure-output-translations #:apply-output-translations + #:compile-file* #:compile-file-pathname* #:enable-asdf-binary-locations-compatibility @@ -327,6 +326,7 @@ '(defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key) (declare (ignorable deleted plist)) + (format *trace-output* "Updating ~A~%" m) (when (member 'components-by-name added) (compute-module-components-by-name m)))))) @@ -336,7 +336,7 @@ (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. You can compare this string with e.g.: -(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")." +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")." *asdf-version*) (defvar *resolve-symlinks* t @@ -344,9 +344,15 @@ Defaults to `t`.") -(defvar *compile-file-warnings-behaviour* :warn) - -(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) +(defvar *compile-file-warnings-behaviour* :warn + "How should ASDF react if it encounters a warning when compiling a +file? Valid values are :error, :warn, and :ignore.") + +(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn + "How should ASDF react if it encounters a failure \(per the +ANSI spec of COMPILE-FILE\) when compiling a file? Valid values are +:error, :warn, and :ignore. Note that ASDF ALWAYS raises an error +if it fails to create an output file when compiling.") (defvar *verbose-out* nil) @@ -365,16 +371,20 @@ ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. - -(defgeneric perform-with-restarts (operation component)) -(defgeneric perform (operation component)) -(defgeneric operation-done-p (operation component)) -(defgeneric explain (operation component)) -(defgeneric output-files (operation component)) -(defgeneric input-files (operation component)) +(defmacro defgeneric* (name formals &rest options) + `(progn + #+(or gcl ecl) (fmakunbound ',name) + (defgeneric ,name ,formals , at options))) + +(defgeneric* perform-with-restarts (operation component)) +(defgeneric* perform (operation component)) +(defgeneric* operation-done-p (operation component)) +(defgeneric* explain (operation component)) +(defgeneric* output-files (operation component)) +(defgeneric* input-files (operation component)) (defgeneric component-operation-time (operation component)) -(defgeneric system-source-file (system) +(defgeneric* system-source-file (system) (:documentation "Return the source file in which system is defined.")) (defgeneric component-system (component) @@ -396,7 +406,7 @@ (defgeneric version-satisfies (component version)) -(defgeneric find-component (base path) +(defgeneric* find-component (base path) (:documentation "Finds the component with PATH starting from BASE module; if BASE is nil, then the component is assumed to be a system.")) @@ -455,17 +465,27 @@ (defgeneric traverse (operation component) (:documentation -"Generate and return a plan for performing `operation` on `component`. +"Generate and return a plan for performing OPERATION on COMPONENT. -The plan returned is a list of dotted-pairs. Each pair is the `cons` -of ASDF operation object and a `component` object. The pairs will be -processed in order by `operate`.")) +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities (defmacro while-collecting ((&rest collectors) &body body) + "COLLECTORS should be a list of names for collections. A collector +defines a function that, when applied to an argument inside BODY, will +add its argument to the corresponding collection. Returns multiple values, +a list for each collection, in order. + E.g., +\(while-collecting \(foo bar\) + \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) + \(foo \(first x\)\) + \(bar \(second x\)\)\)\) +Returns two values: \(A B C\) and \(1 2 3\)." (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) (initial-values (mapcar (constantly nil) collectors))) `(let ,(mapcar #'list vars initial-values) @@ -479,10 +499,8 @@ (defun pathname-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME, TYPE and VERSION components" - (make-pathname :name nil :type nil :version nil :defaults pathname)) - -(defun current-directory () - (truenamize (pathname-directory-pathname *default-pathname-defaults*))) + (when pathname + (make-pathname :name nil :type nil :version nil :defaults pathname))) (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname @@ -493,7 +511,7 @@ (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) - (directory (if (stringp directory) `(:absolute ,directory) directory)) + #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory)) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) @@ -516,9 +534,9 @@ ((:relative) (values (pathname-host defaults) (pathname-device defaults) - (if (null (pathname-directory defaults)) - directory - (append (pathname-directory defaults) (cdr directory))) + (if (pathname-directory defaults) + (append (pathname-directory defaults) (cdr directory)) + directory) (unspecific-handler defaults))) #+gcl (t @@ -538,13 +556,19 @@ (define-modify-macro orf (&rest args) or "or a flag") +(defun first-char (s) + (and (stringp s) (plusp (length s)) (char s 0))) + +(defun last-char (s) + (and (stringp s) (plusp (length s)) (char s (1- (length s))))) + (defun asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) (apply #'format *verbose-out* format-string format-args)) (defun split-string (string &key max (separator '(#\Space #\Tab))) - "Split STRING in components separater by any of the characters in the sequence SEPARATOR, -return a list. + "Split STRING into a list of components separated by +any of the characters in the sequence SEPARATOR. If MAX is specified, then no more than max(1,MAX) components will be returned, starting the separation from the end, e.g. when called with arguments \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." @@ -595,13 +619,14 @@ (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") - (if (and (plusp (length s)) (eql (char s 0) #\/)) + (if (equal (first-char s) #\/) (values :absolute (cdr components)) (values :relative nil)) (values :relative components)) + (setf components (remove "" components :test #'equal)) (cond ((equal last-comp "") - (values relative (butlast components) nil)) + (values relative components nil)) ; "" already removed (force-directory (values relative components nil)) (t @@ -618,17 +643,13 @@ :unless (eq k key) :append (list k v))) -(defun resolve-symlinks (path) - #-allegro (truenamize path) - #+allegro (excl:pathname-resolve-symbolic-links path)) - (defun getenv (x) #+abcl (ext:getenv x) #+sbcl (sb-ext:posix-getenv x) #+clozure - (ccl::getenv x) + (ccl:getenv x) #+clisp (ext:getenv x) #+cmu @@ -643,13 +664,13 @@ (si:getenv x)) (defun directory-pathname-p (pathname) - "Does `pathname` represent a directory? + "Does PATHNAME represent a directory? A directory-pathname is a pathname _without_ a filename. The three -ways that the filename components can be missing are for it to be `nil`, -`:unspecific` or the empty string. +ways that the filename components can be missing are for it to be NIL, +:UNSPECIFIC or the empty string. -Note that this does _not_ check to see that `pathname` points to an +Note that this does _not_ check to see that PATHNAME points to an actually-existing directory." (flet ((check-one (x) (member x '(nil :unspecific "") :test 'equal))) @@ -733,10 +754,8 @@ (directory (pathname-directory p))) (when (typep p 'logical-pathname) (return p)) (ignore-errors (return (truename p))) - (when (stringp directory) - (return p)) - (when (not (eq :absolute (car directory))) - (return p)) + #-sbcl (when (stringp directory) (return p)) + (when (not (eq :absolute (car directory))) (return p)) (let ((sofar (ignore-errors (truename (pathname-root p))))) (unless sofar (return p)) (flet ((solution (directories) @@ -760,9 +779,43 @@ :finally (return (solution nil)))))))) +(defun resolve-symlinks (path) + #-allegro (truenamize path) + #+allegro (excl:pathname-resolve-symbolic-links path)) + +(defun default-directory () + (truenamize (pathname-directory-pathname *default-pathname-defaults*))) + (defun lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) +(defparameter *wild-path* + (make-pathname :directory '(:relative :wild-inferiors) + :name :wild :type :wild :version :wild)) + +(defun wilden (path) + (merge-pathnames* *wild-path* path)) + +(defun directorize-pathname-host-device (pathname) + (let* ((root (pathname-root pathname)) + (wild-root (wilden root)) + (absolute-pathname (merge-pathnames* pathname root)) + (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) + (separator (last-char (namestring foo))) + (root-namestring (namestring root)) + (root-string + (substitute-if #\/ + (lambda (x) (or (eql x #\:) + (eql x separator))) + root-namestring))) + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components root-string t) + (declare (ignore relative filename)) + (let ((new-base + (make-pathname :defaults root + :directory `(:absolute , at path)))) + (translate-pathname absolute-pathname wild-root (wilden new-base)))))) + ;;;; ------------------------------------------------------------------------- ;;;; Classes, Conditions @@ -775,6 +828,15 @@ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object)) +(declaim (ftype (function (t) t) + format-arguments format-control + error-name error-pathname error-condition + duplicate-names-name + error-component error-operation + module-components module-components-by-name) + (ftype (function (t t) t) (setf module-components-by-name))) + + (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) @@ -894,8 +956,8 @@ (defvar *default-component-class* 'cl-source-file) (defun compute-module-components-by-name (module) - (let ((hash (module-components-by-name module))) - (clrhash hash) + (let ((hash (make-hash-table :test 'equal))) + (setf (module-components-by-name module) hash) (loop :for c :in (module-components module) :for name = (component-name c) :for previous = (gethash name (module-components-by-name module)) @@ -911,7 +973,6 @@ :initarg :components :accessor module-components) (components-by-name - :initform (make-hash-table :test 'equal) :accessor module-components-by-name) ;; What to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing. @@ -939,7 +1000,7 @@ (let ((pathname (merge-pathnames* (component-relative-pathname component) - (component-parent-pathname component)))) + (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) (error "Invalid relative pathname ~S for component ~S" pathname component)) (setf (slot-value component 'absolute-pathname) pathname) @@ -1013,9 +1074,9 @@ (gethash (coerce-name name) *defined-systems*)) (defun map-systems (fn) - "Apply `fn` to each defined system. + "Apply FN to each defined system. -`fn` should be a function of one argument. It will be +FN should be a function of one argument. It will be called with an object of type asdf:system." (maphash (lambda (_ datum) (declare (ignore _)) @@ -1028,7 +1089,7 @@ ;;; convention that functions in this list are prefixed SYSDEF- (defparameter *system-definition-search-functions* - '(sysdef-central-registry-search sysdef-source-registry-search)) + '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) (defun system-definition-pathname (system) (let ((system-name (coerce-name system))) @@ -1054,6 +1115,27 @@ Going forward, we recommend new users should be using the source-registry. ") +(defun probe-asd (name defaults) + (block nil + (when (directory-pathname-p defaults) + (let ((file + (make-pathname + :defaults defaults :version :newest :case :local + :name name + :type "asd"))) + (when (probe-file file) + (return file))) + #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) + (let ((shortcut + (make-pathname + :defaults defaults :version :newest :case :local + :name (concatenate 'string name ".asd") + :type "lnk"))) + (when (probe-file shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target))))))))) + (defun sysdef-central-registry-search (system) (let ((name (coerce-name system)) (to-remove nil) @@ -1072,8 +1154,8 @@ (let* ((*print-circle* nil) (message (format nil - "~@" + "~@" system dir defaults))) (error message)) (remove-entry-from-registry () @@ -1122,37 +1204,50 @@ 0))) (defun find-system (name &optional (error-p t)) - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) - (on-disk (system-definition-pathname name))) - (when (and on-disk - (or (not in-memory) - (< (car in-memory) (safe-file-write-date on-disk)))) - (let ((package (make-temporary-package))) - (unwind-protect - (handler-bind - ((error (lambda (condition) - (error 'load-system-definition-error - :name name :pathname on-disk - :condition condition)))) - (let ((*package* package)) - (asdf-message - "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" - on-disk *package*) - (load on-disk))) - (delete-package package)))) - (let ((in-memory (system-registered-p name))) - (if in-memory - (progn (when on-disk (setf (car in-memory) - (safe-file-write-date on-disk))) - (cdr in-memory)) - (when error-p (error 'missing-component :requires name)))))) + (catch 'find-system + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (safe-file-write-date on-disk)))) + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error (lambda (condition) + (error 'load-system-definition-error + :name name :pathname on-disk + :condition condition)))) + (let ((*package* package)) + (asdf-message + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + on-disk *package*) + (load on-disk))) + (delete-package package)))) + (let ((in-memory (system-registered-p name))) + (if in-memory + (progn (when on-disk (setf (car in-memory) + (safe-file-write-date on-disk))) + (cdr in-memory)) + (when error-p (error 'missing-component :requires name))))))) (defun register-system (name system) (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) +(defun sysdef-find-asdf (system) + (let ((name (coerce-name system))) + (when (equal name "asdf") + (let* ((registered (cdr (gethash name *defined-systems*))) + (asdf (or registered + (make-instance + 'system :name "asdf" + :source-file (or *compile-file-truename* *load-truename*))))) + (unless registered + (register-system "asdf" asdf)) + (throw 'find-system asdf))))) + ;;;; ------------------------------------------------------------------------- ;;;; Finding components @@ -1171,8 +1266,9 @@ (find-component (car base) (cons (cdr base) path))) (defmethod find-component ((module module) (name string)) - (when (slot-boundp module 'components-by-name) - (values (gethash name (module-components-by-name module))))) + (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!! + (compute-module-components-by-name module)) + (values (gethash name (module-components-by-name module)))) (defmethod find-component ((component component) (name symbol)) (if name @@ -1602,19 +1698,6 @@ (visit-component operation c flag) flag)) -(defmethod traverse ((operation operation) (c component)) - ;; cerror'ing a feature that seems to have NEVER EVER worked - ;; ever since danb created it in his 2003-03-16 commit e0d02781. - ;; It was both fixed and disabled in the 1.700 rewrite. - (when (consp (operation-forced operation)) - (cerror "Continue nonetheless." - "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") - (setf (operation-forced operation) - (mapcar #'coerce-name (operation-forced operation)))) - (flatten-tree - (while-collecting (collect) - (do-traverse operation c #'collect)))) - (defun flatten-tree (l) ;; You collected things into a list. ;; Most elements are just things to collect again. @@ -1631,6 +1714,19 @@ (dolist (x l) (r x)))) (r* l)))) +(defmethod traverse ((operation operation) (c component)) + ;; cerror'ing a feature that seems to have NEVER EVER worked + ;; ever since danb created it in his 2003-03-16 commit e0d02781. + ;; It was both fixed and disabled in the 1.700 rewrite. + (when (consp (operation-forced operation)) + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") + (setf (operation-forced operation) + (mapcar #'coerce-name (operation-forced operation)))) + (flatten-tree + (while-collecting (collect) + (do-traverse operation c #'collect)))) + (defmethod perform ((operation operation) (c source-file)) (sysdef-error "~@" type)))) + (or (loop :for symbol :in (list + (unless (keywordp type) type) + (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) :asdf)) + :for class = (and symbol (find-class symbol nil)) + :when (and class (subtypep class 'component)) + :return class) + (and (eq type :file) + (or (module-default-component-class parent) + (find-class *default-component-class*))) + (sysdef-error "~@" type))) (defun maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. @@ -2178,9 +2271,9 @@ ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 (defun run-shell-command (control-string &rest args) - "Interpolate `args` into `control-string` as if by `format`, and + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with -output to `*verbose-out*`. Returns the shell's exit code." +output to *VERBOSE-OUT*. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) (asdf-message "; $ ~A~%" command) @@ -2333,7 +2426,7 @@ (when (member :lispworks-64bit *features*) "-64bit")) ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) - #+(or mcl sbcl scl) s + #+(or cormanlisp mcl sbcl scl) s #-(or allegro armedbear clisp clozure cmu cormanlisp digitool ecl gcl lispworks mcl sbcl scl) s)) @@ -2453,10 +2546,15 @@ (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) (funcall validator (car forms)))) +(defun hidden-file-p (pathname) + (equal (first-char (pathname-name pathname)) #\.)) + (defun validate-configuration-directory (directory tag validator) (let ((files (sort (ignore-errors - (directory (make-pathname :name :wild :type :wild :defaults directory) - #+sbcl :resolve-symlinks #+sbcl nil)) + (remove-if + 'hidden-file-p + (directory (make-pathname :name :wild :type "conf" :defaults directory) + #+sbcl :resolve-symlinks #+sbcl nil))) #'string< :key #'namestring))) `(,tag ,@(loop :for file :in files :append @@ -2513,16 +2611,38 @@ (setf *output-translations* '()) (values)) -(defparameter *wild-path* - (make-pathname :directory '(:relative :wild-inferiors) - :name :wild :type :wild :version :wild)) - (defparameter *wild-asd* (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type "asd" :version :newest)) -(defun wilden (path) - (merge-pathnames* *wild-path* path)) + +(declaim (ftype (function (t &optional boolean) (or null pathname)) + resolve-location)) + +(defun resolve-relative-location-component (super x &optional wildenp) + (let* ((r (etypecase x + (pathname x) + (string x) + (cons + (let ((car (resolve-relative-location-component super (car x) nil))) + (if (null (cdr x)) + car + (let ((cdr (resolve-relative-location-component + (merge-pathnames* car super) (cdr x) wildenp))) + (merge-pathnames* cdr car))))) + ((eql :default-directory) + (relativize-pathname-directory (default-directory))) + ((eql :implementation) (implementation-identifier)) + ((eql :implementation-type) (string-downcase (implementation-type))) + #-(and (or win32 windows mswindows mingw32) (not cygwin)) + ((eql :uid) (princ-to-string (get-uid))))) + (d (if (pathnamep x) r (ensure-directory-pathname r))) + (s (if (and wildenp (not (pathnamep x))) + (wilden d) + d))) + (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) + (error "pathname ~S is not relative to ~S" s super)) + (merge-pathnames* s super))) (defun resolve-absolute-location-component (x wildenp) (let* ((r @@ -2544,7 +2664,7 @@ ((eql :home) (user-homedir)) ((eql :user-cache) (resolve-location *user-cache* nil)) ((eql :system-cache) (resolve-location *system-cache* nil)) - ((eql :current-directory) (current-directory)))) + ((eql :default-directory) (default-directory)))) (s (if (and wildenp (not (pathnamep x))) (wilden r) r))) @@ -2552,30 +2672,6 @@ (error "Not an absolute pathname ~S" s)) s)) -(defun resolve-relative-location-component (super x &optional wildenp) - (let* ((r (etypecase x - (pathname x) - (string x) - (cons - (let ((car (resolve-relative-location-component super (car x) nil))) - (if (null (cdr x)) - car - (let ((cdr (resolve-relative-location-component - (merge-pathnames* car super) (cdr x) wildenp))) - (merge-pathnames* cdr car))))) - ((eql :current-directory) - (relativize-pathname-directory (current-directory))) - ((eql :implementation) (implementation-identifier)) - ((eql :implementation-type) (string-downcase (implementation-type))) - ((eql :uid) (princ-to-string (get-uid))))) - (d (if (pathnamep x) r (ensure-directory-pathname r))) - (s (if (and wildenp (not (pathnamep x))) - (wilden d) - d))) - (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) - (error "pathname ~S is not relative to ~S" s super)) - (merge-pathnames* s super))) - (defun resolve-location (x &optional wildenp) (if (atom x) (resolve-absolute-location-component x wildenp) @@ -2681,8 +2777,8 @@ ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. #+sbcl (,(getenv "SBCL_HOME") ()) - #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually. - #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system + #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system + #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: @@ -2706,6 +2802,11 @@ (getenv "ASDF_OUTPUT_TRANSLATIONS")) (defgeneric process-output-translations (spec &key inherit collect)) +(declaim (ftype (function (t &key (:collect (or symbol function))) t) + inherit-output-translations)) +(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t) + process-output-translations-directive)) + (defmethod process-output-translations ((x symbol) &key (inherit *default-output-translations*) collect) @@ -2833,29 +2934,6 @@ (translate-pathname p absolute-source destination))) :finally (return p))))) -(defun last-char (s) - (and (stringp s) (plusp (length s)) (char s (1- (length s))))) - -(defun directorize-pathname-host-device (pathname) - (let* ((root (pathname-root pathname)) - (wild-root (wilden root)) - (absolute-pathname (merge-pathnames* pathname root)) - (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) - (separator (last-char (namestring foo))) - (root-namestring (namestring root)) - (root-string - (substitute-if #\/ - (lambda (x) (or (eql x #\:) - (eql x separator))) - root-namestring))) - (multiple-value-bind (relative path filename) - (component-name-to-pathname-components root-string t) - (declare (ignore relative filename)) - (let ((new-base - (make-pathname :defaults root - :directory `(:absolute , at path)))) - (translate-pathname absolute-pathname wild-root (wilden new-base)))))) - (defmethod output-files :around (operation component) "Translate output files, unless asked not to" (declare (ignorable operation component)) @@ -2866,11 +2944,45 @@ (mapcar #'apply-output-translations files))) t)) -(defun compile-file-pathname* (input-file &rest keys) - (apply-output-translations - (apply #'compile-file-pathname - (truenamize (lispize-pathname input-file)) - keys))) +(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + (or output-file + (apply-output-translations + (apply 'compile-file-pathname + (truenamize (lispize-pathname input-file)) + keys)))) + +(defun tmpize-pathname (x) + (make-pathname + :name (format nil "ASDF-TMP-~A" (pathname-name x)) + :defaults x)) + +(defun delete-file-if-exists (x) + (when (probe-file x) + (delete-file x))) + +(defun compile-file* (input-file &rest keys &key &allow-other-keys) + (let* ((output-file (apply 'compile-file-pathname* input-file keys)) + (tmp-file (tmpize-pathname output-file)) + (status :error)) + (multiple-value-bind (output-truename warnings-p failure-p) + (apply 'compile-file input-file :output-file tmp-file keys) + (cond + (failure-p + (setf status *compile-file-failure-behaviour*)) + (warnings-p + (setf status *compile-file-warnings-behaviour*)) + (t + (setf status :success))) + (ecase status + ((:success :warn :ignore) + (delete-file-if-exists output-file) + (when output-truename + (rename-file output-truename output-file) + (setf output-truename output-file))) + (:error + (delete-file-if-exists output-truename) + (setf output-truename nil))) + (values output-truename warnings-p failure-p)))) #+abcl (defun translate-jar-pathname (source wildcard) @@ -2998,11 +3110,13 @@ ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 ;; Using ack 1.2 exclusions -(defvar *default-exclusions* +(defvar *default-source-registry-exclusions* '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build")) +(defvar *source-registry-exclusions* *default-source-registry-exclusions*) + (defvar *source-registry* () "Either NIL (for uninitialized), or a list of one element, said element itself being a list of directory pathnames where to look for .asd files") @@ -3024,34 +3138,6 @@ (setf *source-registry* '()) (values)) -(defun probe-asd (name defaults) - (block nil - (when (directory-pathname-p defaults) - (let ((file - (make-pathname - :defaults defaults :version :newest :case :local - :name name - :type "asd"))) - (when (probe-file file) - (return file))) - #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) - (let ((shortcut - (make-pathname - :defaults defaults :version :newest :case :local - :name (concatenate 'string name ".asd") - :type "lnk"))) - (when (probe-file shortcut) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target))))))))) - -(defun sysdef-source-registry-search (system) - (ensure-source-registry) - (loop :with name = (coerce-name system) - :for defaults :in (source-registry) - :for file = (probe-asd name defaults) - :when file :return file)) - (defun validate-source-registry-directive (directive) (unless (or (member directive '(:default-registry (:default-registry)) :test 'equal) @@ -3060,7 +3146,7 @@ ((:include :directory :tree) (and (length=n-p rest 1) (typep (car rest) '(or pathname string null)))) - ((:exclude) + ((:exclude :also-exclude) (every #'stringp rest)) (null rest)))) (error "Invalid directive ~S~%" directive)) @@ -3146,7 +3232,8 @@ (defun wrapping-source-registry () `(:source-registry #+sbcl (:tree ,(getenv "SBCL_HOME")) - :inherit-configuration)) + :inherit-configuration + #+cmu (:tree #p"modules:"))) (defun default-source-registry () (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(:source-registry @@ -3185,6 +3272,11 @@ (getenv "CL_SOURCE_REGISTRY")) (defgeneric process-source-registry (spec &key inherit register)) +(declaim (ftype (function (t &key (:register (or symbol function))) t) + inherit-source-registry)) +(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t) + process-source-registry-directive)) + (defmethod process-source-registry ((x symbol) &key inherit register) (process-source-registry (funcall x) :inherit inherit :register register)) (defmethod process-source-registry ((pathname pathname) &key inherit register) @@ -3204,7 +3296,7 @@ (declare (ignorable x)) (inherit-source-registry inherit :register register)) (defmethod process-source-registry ((form cons) &key inherit register) - (let ((*default-exclusions* *default-exclusions*)) + (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) (dolist (directive (cdr (validate-source-registry-form form))) (process-source-registry-directive directive :inherit inherit :register register)))) @@ -3225,15 +3317,18 @@ ((:tree) (destructuring-bind (pathname) rest (when pathname - (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*)))) + (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*)))) ((:exclude) - (setf *default-exclusions* rest)) + (setf *source-registry-exclusions* rest)) + ((:also-exclude) + (appendf *source-registry-exclusions* rest)) ((:default-registry) (inherit-source-registry '(default-source-registry) :register register)) ((:inherit-configuration) (inherit-source-registry inherit :register register)) ((:ignore-inherited-configuration) - nil)))) + nil))) + nil) (defun flatten-source-registry (&optional parameter) (remove-duplicates @@ -3268,6 +3363,13 @@ (source-registry) (initialize-source-registry))) +(defun sysdef-source-registry-search (system) + (ensure-source-registry) + (loop :with name = (coerce-name system) + :for defaults :in (source-registry) + :for file = (probe-asd name defaults) + :when file :return file)) + ;;;; ----------------------------------------------------------------- ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL ;;;; @@ -3278,16 +3380,16 @@ ((style-warning #'muffle-warning) (missing-component (constantly nil)) (error (lambda (e) - (format *error-output* "ASDF could not load ~A because ~A.~%" + (format *error-output* "ASDF could not load ~(~A~) because ~A.~%" name e)))) (let* ((*verbose-out* (make-broadcast-stream)) - (system (find-system name nil))) + (system (find-system (string-downcase name) nil))) (when system - (load-system name) + (load-system system) t)))) (pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* - #+clozure ccl::*module-provider-functions* + #+clozure ccl:*module-provider-functions* #+cmu ext:*module-provider-functions* #+ecl si:*module-provider-functions* #+sbcl sb-ext:*module-provider-functions*)) @@ -3312,7 +3414,7 @@ ;;;; ----------------------------------------------------------------- ;;;; Done! (when *load-verbose* - (asdf-message ";; ASDF, version ~a" (asdf-version))) + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) #+allegro (eval-when (:compile-toplevel :execute) @@ -3320,7 +3422,6 @@ (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) (pushnew :asdf *features*) -;; this is a release candidate for ASDF 2.0 (pushnew :asdf2 *features*) (provide :asdf) From ehuelsmann at common-lisp.net Fri Jun 25 20:44:26 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 25 Jun 2010 16:44:26 -0400 Subject: [armedbear-cvs] r12766 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jun 25 16:44:23 2010 New Revision: 12766 Log: Fix #101: Regression in 0.20 where dispatch macros return NIL. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Fri Jun 25 16:44:23 2010 @@ -523,8 +523,10 @@ // If we're looking at zero return values, set 'value' to null if (value == NIL) { LispObject[] values = thread._values; - if (values != null && values.length == 0) + if (values != null && values.length == 0) { value = null; + thread._values = null; // reset 'no values' indicator + } } return value; } From ehuelsmann at common-lisp.net Fri Jun 25 22:59:25 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 25 Jun 2010 18:59:25 -0400 Subject: [armedbear-cvs] r12767 - in branches/generic-class-file/abcl: . src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jun 25 18:59:25 2010 New Revision: 12767 Log: More work-in-progress. Add file mistakenly not committed with WIP commit: it's the most important part. Added: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/README.BRANCH Modified: branches/generic-class-file/abcl/README.BRANCH ============================================================================== --- branches/generic-class-file/abcl/README.BRANCH (original) +++ branches/generic-class-file/abcl/README.BRANCH Fri Jun 25 18:59:25 2010 @@ -35,11 +35,34 @@ +Design +====== + + + Status ====== The replacement code is located in the java-class-file.lisp file. +TODO: + + * All methods preceded by an exclamation mark have equal names in + compiler-pass2; this situation is to be resolved eventually. + Preferrably even before merging back to trunk. + + * Move 'code-bytes' to opcodes.lisp + + * Rename opcodes.lisp to jvm-opcodes.lisp [probably more an action for trunk/] + + * Writing unit-tests + + * Write compiler-pass2.lisp to use WITH-CODE-TO-METHOD to select the + method to send output to + + * + + The rest of the status is still to be described. Added: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- (empty file) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Fri Jun 25 18:59:25 2010 @@ -0,0 +1,638 @@ +;;; jvm-class-file.lisp +;;; +;;; Copyright (C) 2010 Erik Huelsmann +;;; $Id: compiler-pass2.lisp 12311 2009-12-28 23:11:35Z ehuelsmann $ +;;; +;;; 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. + +(in-package "JVM") + +#| + +The general design of the class-file writer is to have generic +- human readable - representations of the class being generated +during the construction and manipulation phases. + +After completing the creation/manipulation of the class, all its +components will be finalized. This process translates readable +(e.g. string) representations to indices to be stored on disc. + +The only thing to be done after finalization is sending the +output to a stream ("writing"). + + +Finalization happens highest-level first. As an example, take a +method with exception handlers. The exception handlers are stored +as attributes in the class file structure. They are children of the +method's Code attribute. In this example, the body of the Code +attribute (the higher level) gets finalized before the attributes. +The reason to do so is that the exceptions need to refer to labels +(offsets) in the Code segment. + + +|# + + +(defun map-primitive-type (type) + (case type + (:int "I") + (:long "J") + (:float "F") + (:double "D") + (:boolean "Z") + (:char "C") + (:byte "B") + (:short "S") + (:void "V"))) + + +#| + +The `class-name' facility helps to abstract from "this instruction takes +a reference" and "this instruction takes a class name". We simply pass +the class name around and the instructions themselves know which +representation to use. + +|# + +(defstruct (class-name (:conc-name class-) + (:constructor %make-class-name)) + name-internal + ref + array-ref) + +(defun make-class-name (name) + (setf name (substitute #\/ #\. name)) + (%make-class-name :name-internal name + :ref (concatenate 'string "L" name ";") + :array-ref (concatenate 'string "[L" name ";"))) + +(defmacro define-class-name (symbol java-dotted-name &optional documentation) + `(defconstant ,symbol (make-class-name ,java-dotted-name) + ,documentation)) + +(define-class-name +!java-object+ "java.lang.Object") +(define-class-name +!java-string+ "java.lang.String") +(define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject") +(define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString") +(define-class-name +!lisp+ "org.armedbear.lisp.Lisp") +(define-class-name +!lisp-nil+ "org.armedbear.lisp.Nil") +(define-class-name +!lisp-class+ "org.armedbear.lisp.LispClass") +(define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol") +(define-class-name +!lisp-thread+ "org.armedbear.lisp.LispThread") +(define-class-name +!lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding") +(define-class-name +!lisp-integer+ "org.armedbear.lisp.Integer") +(define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum") +(define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum") +(define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat") +(define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat") +(define-class-name +!lisp-cons+ "org.armedbear.lisp.Cons") +(define-class-name +!lisp-load+ "org.armedbear.lisp.Load") +(define-class-name +!lisp-character+ "org.armedbear.lisp.Character") +(define-class-name +!lisp-simple-vector+ "org.armedbear.lisp.SimpleVector") +(define-class-name +!lisp-abstract-string+ "org.armedbear.lisp.AbstractString") +(define-class-name +!lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector") +(define-class-name +!lisp-abstract-bit-vector+ + "org.armedbear.lisp.AbstractBitVector") +(define-class-name +!lisp-environment+ "org.armedbear.lisp.Environment") +(define-class-name +!lisp-special-binding+ "org.armedbear.lisp.SpecialBinding") +(define-class-name +!lisp-special-binding-mark+ + "org.armedbear.lisp.SpecialBindingMark") +(define-class-name +!lisp-throw+ "org.armedbear.lisp.Throw") +(define-class-name +!lisp-return+ "org.armedbear.lisp.Return") +(define-class-name +!lisp-go+ "org.armedbear.lisp.Go") +(define-class-name +!lisp-primitive+ "org.armedbear.lisp.Primitive") +(define-class-name +!lisp-compiled-closure+ + "org.armedbear.lisp.CompiledClosure") +(define-class-name +!lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable") +(define-class-name +!lisp-package+ "org.armedbear.lisp.Package") +(define-class-name +!lisp-readtable+ "org.armedbear.lisp.Readtable") +(define-class-name +!lisp-stream+ "org.armedbear.lisp.Stream") +(define-class-name +!lisp-closure+ "org.armedbear.lisp.Closure") +(define-class-name +!lisp-closure-parameter+ + "org.armedbear.lisp.Closure$Parameter") +(define-class-name +!fasl-loader+ "org.armedbear.lisp.FaslClassLoader") + + +(defun descriptor (method-name return-type &rest argument-types) + (format nil "~A(~{~A~}~A)" method-name + (mapcar #'(lambda (arg-type) + (if (keywordp arg-type) + (map-primitive-type arg-type) + (class-ref arg-type))) + argument-types) + (if (keywordp return-type) + (map-primitive-type return-type) + (class-name-internal return-type)))) + + + + + +(defstruct pool + (count 1) ;; #### why count 1??? + entries-list + (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0))) + +(defstruct constant + tag + index) + +(defparameter +constant-type-map+ + '((:class 7 1) + (:field-ref 9 1) + (:method-ref 10 1) + ;; (:interface-method-ref 11) + (:string 8 1) + (:integer 3 1) + (:float 4 1) + (:long 5 2) + (:double 6 2) + (:name-and-type 12 1) + (:utf8 1 1))) + +(defstruct (constant-class (:include constant + (tag 7))) + name) + +(defstruct (constant-member-ref (:include constant)) + class + name/type) + +(defstruct (constant-string (:constructor make-constant-string (value-index)) + (:include constant + (tag 8))) + value-index) ;;; #### is this the value or the value index??? + +(defstruct (constant-float/int (:include constant)) + value) + +(defstruct (constant-double/long (:include constant)) + value) + +(defstruct (constant-name/type (:include constant)) + name-index + descriptor-index) + +(defstruct (constant-utf8 (:include constant)) + value) + + +;; Need to add pool/constant creation addition routines here; +;; all routines have 2 branches: return existing or push new. + +(defun pool-add-string (pool string) + (let ((entry (gethash (pool-entries string)))) + (unless entry + (setf entry (make-constant-string (pool-count pool) string)) + (push entry (pool-entries-list pool)) + (incf (pool-count pool))) + (constant-index entry))) + + + +(defstruct (class-file (:constructor %make-class-file)) + constants + access-flags + class + superclass + ;; interfaces + fields + methods + attributes + ) + +(defun class-add-field (class field) + (push field (class-file-fields class))) + +(defun class-field (class name) + (find name (class-file-fields class) + :test #'string= :key #'field-name)) + +(defun class-add-method (class method) + (push method (class-file-methods class))) + +(defun class-methods-by-name (class name) + (remove (map-method-name name) (class-file-methods class) + :test-not #'string= :key #'method-name)) + +(defun class-method (class descriptor) + (find descriptor (class-file-methods class) + :test #'string= :key #'method-name)) + + +(defun finalize-class-file (class) + + ;; constant pool contains constants finalized on addition; + ;; no need for additional finalization + + (setf (class-file-access-flags class) + (map-flags (class-file-access-flags class))) + ;; (finalize-class-name ) + ;; (finalize-interfaces) + (dolist (field (class-file-fields class)) + (finalize-field field class)) + (dolist (method (class-file-methods class)) + (finalize-method method class)) + ;; top-level attributes (no parent attributes to refer to) + (finalize-attributes (class-file-attributes class) nil class) + +) + +(defun !write-class-file (class stream) + ;; all components need to finalize themselves: + ;; the constant pool needs to be complete before we start + ;; writing our output. + + ;; header + (write-u4 #xCAFEBABE stream) + (write-u2 3 stream) + (write-u2 45 stream) + + ;; constants pool + (write-constants (class-file-constants class) stream) + ;; flags + (write-u2 (class-file-access-flags class) stream) + ;; class name + (write-u2 (class-file-class class) stream) + ;; superclass + (write-u2 (class-file-superclass class) stream) + + ;; interfaces + (write-u2 0 stream) + + ;; fields + (write-u2 (length (class-file-fields class)) stream) + (dolist (field (class-file-fields class)) + (!write-field field stream)) + + ;; methods + (write-u2 (length (class-file-methods class)) stream) + (dolist (method (class-file-methods class)) + (!write-method method stream)) + + ;; attributes + (write-attributes (class-file-attributes class) stream)) + +(defun write-constants (constants stream) + (write-u2 (pool-count constants) stream) + (dolist (entry (reverse (pool-entries-list constants))) + (let ((tag (constant-tag entry))) + (write-u1 tag stream) + (case tag + (1 ; UTF8 + (write-utf8 (constant-utf8-value entry) stream)) + ((3 4) ; int + (write-u4 (constant-float/int-value entry) stream)) + ((5 6) ; long double + (write-u4 (second entry) stream) + (write-u4 (third entry) stream)) + ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType + (write-u2 (second entry) stream) + (write-u2 (third entry) stream)) + ((7 8) ; class string + (write-u2 (constant-class-name entry) stream)) + (t + (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))) + +#| + +ABCL doesn't use interfaces, so don't implement it here at this time + +(defstruct interface) + +|# + + +(defparameter +access-flags-map+ + '((:public #x0001) + (:private #x0002) + (:protected #x0004) + (:static #x0008) + (:final #x0010) + (:volatile #x0040) + (:synchronized #x0020) + (:transient #x0080) + (:native #x0100) + (:abstract #x0400) + (:strict #x0800))) + +(defun map-flags (flags) + (reduce #'(lambda (x y) + (logior (or (when (member (car x) flags) + (second x)) + 0) y) + (logior (or ))) + :initial-value 0)) + +(defstruct (field (:constructor %make-field)) + access-flags + name + descriptor + attributes + ) + +(defun make-field (name type &key (flags '(:public))) + (%make-field :access-flags flags + :name name + :descriptor (map-primitive-type type))) + +(defun add-field-attribute (field attribute) + (push attribute (field-attributes field))) + + +(defun finalize-field (field class) + (declare (ignore class field)) + (error "Not implemented")) + +(defun !write-field (field stream) + (declare (ignore field stream)) + (error "Not implemented")) + + +(defstruct (method (:constructor %!make-method)) + access-flags + name + descriptor + attributes + arg-count ;; not in the class file, + ;; but required for setting up CODE attribute + ) + + +(defun map-method-name (name) + (cond + ((eq name :class-constructor) + "") + ((eq name :constructor) + "") + (t name))) + +(defun !make-method-descriptor (name return &rest args) + (apply #'concatenate (append (list 'string (map-method-name name) "(") + (mapcar #'map-primitive-type args) + (list ")" return)))) + +(defun !make-method (name return args &key (flags '(:public))) + (setf name (map-method-name name)) + (%make-method :descriptor (apply #'make-method-descriptor + name return args) + :access-flags flags + :name name + :arg-count (if (member :static flags) + (length args) + (1+ (length args))))) ;; implicit 'this' + +(defun method-add-attribute (method attribute) + (push attribute (method-attributes method))) + +(defun method-attribute (method name) + (find name (method-attributes method) + :test #'string= :key #'attribute-name)) + + +(defun finalize-method (method class) + (declare (ignore method class)) + (error "Not implemented")) + + +(defun !write-method (method stream) + (declare (ignore method stream)) + (error "Not implemented")) + +(defstruct attribute + name + + ;; not in the class file: + finalizer ;; function of 3 arguments: the attribute, parent and class-file + writer ;; function of 2 arguments: the attribute and the output stream + ) + +(defun finalize-attributes (attributes att class) + (dolist (attribute attributes) + ;; assure header: make sure 'name' is in the pool + (setf (attribute-name attribute) + (pool-add-string (class-file-constants class) + (attribute-name attribute))) + ;; we're saving "root" attributes: attributes which have no parent + (funcall (attribute-finalizer attribute) attribute att class))) + +(defun write-attributes (attributes stream) + (write-u2 (length attributes) stream) + (dolist (attribute attributes) + (write-u2 (attribute-name attribute) stream) + ;; set up a bulk catcher for (UNSIGNED-BYTE 8) + ;; since we need to know the attribute length (excluding the header) + (let ((local-stream (sys::%make-byte-array-output-stream))) + (funcall (attribute-writer attribute) attribute local-stream) + (let ((array (sys::%get-output-stream-array local-stream))) + (write-u2 (length array) stream) + (write-sequence array stream))))) + + + +(defstruct (code-attribute (:conc-name code-) + (:include attribute + (name "Code") + (finalizer #'!finalize-code) + (writer #'!write-code)) + (:constructor %make-code-attribute)) + max-stack + max-locals + code + attributes + ;; labels contains offsets into the code array after it's finalized + (labels (make-hash-table :test #'eq)) + + ;; fields not in the class file start here + current-local ;; used for handling nested WITH-CODE-TO-METHOD blocks + ) + + +(defun code-label-offset (code label) + (gethash label (code-labels code))) + +(defun (setf code-label-offset) (offset code label) + (setf (gethash label (code-labels code)) offset)) + +(defun !finalize-code (code class) + (let ((c (coerce (resolve-instructions (code-code code)) 'vector))) + (setf (code-max-stack code) (analyze-stack c) + (code-code code) (code-bytes c))) + (finalize-attributes (code-attributes code) code class)) + +(defun !write-code (code stream) + (write-u2 (code-max-stack code) stream) + (write-u2 (code-max-locals code) stream) + (let ((code-array (code-code code))) + (write-u4 (length code-array) stream) + (dotimes (i (length code-array)) + (write-u1 (svref code-array i) stream))) + (write-attributes (code-attributes code) stream)) + +(defun make-code-attribute (method) + (%make-code-attribute :max-locals (method-arg-count method))) + +(defun code-add-attribute (code attribute) + (push attribute (code-attributes code))) + +(defun code-attribute (code name) + (find name (code-attributes code) + :test #'string= :key #'attribute-name)) + + + +(defvar *current-code-attribute*) + +(defun save-code-specials (code) + (setf (code-code code) *code* + (code-max-locals code) *registers-allocated* + (code-exception-handlers code) *handlers* + (code-current-local code) *register*)) + +(defun restore-code-specials (code) + (setf *code* (code-code code) + *registers-allocated* (code-max-locals code) + *register* (code-current-local code))) + +(defmacro with-code-to-method ((method &key safe-nesting) &body body) + (let ((m (gensym)) + (c (gensym))) + `(progn + ,@(when safe-nesting + `((when *current-code-attribute* + (save-code-specials *current-code-attribute*)))) + (let* ((,m ,method) + (,c (method-attribute ,m "Code")) + (*code* (code-code ,c)) + (*registers-allocated* (code-max-locals ,c)) + (*register* (code-current-local ,c)) + (*current-code-attribute* ,c)) + , at body + (setf (code-code ,c) *code* + (code-exception-handlers ,c) *handlers* + (code-max-locals ,c) *registers-allocated*)) + ,@(when safe-nesting + `((when *current-code-attribute* + (restore-code-specials *current-code-attribute*))))))) + +(defstruct (exceptions-attribute (:constructor make-exceptions) + (:conc-name exceptions-) + (:include attribute + (name "Exceptions") + (finalizer #'finalize-exceptions) + (writer #'write-exceptions))) + exceptions) + +(defun finalize-exceptions (exceptions code class) + (dolist (exception (exceptions-exceptions exceptions)) + ;; no need to finalize `catch-type': it's already the index required + (setf (exception-start-pc exception) + (code-label-offset code (exception-start-pc exception)) + (exception-end-pc exception) + (code-label-offset code (exception-end-pc exception)) + (exception-handler-pc exception) + (code-label-offset code (exception-handler-pc exception)) + (exception-catch-type exception) + (pool-add-string (class-file-constants class) + (exception-catch-type exception)))) + ;;(finalize-attributes (exceptions-attributes exception) exceptions class) + ) + + +(defun write-exceptions (exceptions stream) + ; number of entries + (write-u2 (length (exceptions-exceptions exceptions)) stream) + (dolist (exception (exceptions-exceptions exceptions)) + (write-u2 (exception-start-pc exception) stream) + (write-u2 (exception-end-pc exception) stream) + (write-u2 (exception-handler-pc exception) stream) + (write-u2 (exception-catch-type exception) stream))) + +(defun code-add-exception (code start end handler type) + (when (null (code-attribute code "Exceptions")) + (code-add-attribute code (make-exceptions))) + (push (make-exception :start-pc start + :end-pc end + :handler-pc handler + :catch-type type) + (exceptions-exceptions (code-attribute code "Exceptions")))) + +(defstruct exception + start-pc ;; label target + end-pc ;; label target + handler-pc ;; label target + catch-type ;; a string for a specific type, or NIL for all + ) + +(defstruct (source-file-attribute (:conc-name source-) + (:include attribute + (name "SourceFile"))) + filename) + +(defstruct (line-numbers-attribute (:include attribute + (name "LineNumberTable"))) + line-numbers) + +(defstruct line-number + start-pc + line) + +(defstruct (local-variables-attribute (:conc-name local-var-) + (:include attribute + (name "LocalVariableTable"))) + locals) + +(defstruct (local-variable (:conc-name local-)) + start-pc + length + name + descriptor + index) + +#| + +;; this is the minimal sequence we need to support: + +;; create a class file structure +;; add methods +;; add code to the methods, switching from one method to the other +;; finalize the methods, one by one +;; write the class file + +to support the sequence above, we probably need to +be able to + +- find methods by signature +- find the method's code attribute +- add code to the code attribute +- finalize the code attribute contents (blocking it for further addition) +- + + +|# + From ehuelsmann at common-lisp.net Sun Jun 27 10:10:40 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 27 Jun 2010 06:10:40 -0400 Subject: [armedbear-cvs] r12768 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jun 27 06:10:38 2010 New Revision: 12768 Log: Fix elimination of unused local functions: macroexpand before scanning the body. Found by: William Wadsworth (will wadsworth 10 at gmail com) Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Sun Jun 27 06:10:38 2010 @@ -788,7 +788,9 @@ (let ((*precompile-env* (make-environment *precompile-env*)) (operator (car form)) (locals (cadr form)) - (body (cddr form))) + ;; precompile (thus macro-expand) the body before inspecting it + ;; for the use of our locals and optimizing them away + (body (mapcar #'precompile1 (cddr form)))) (dolist (local locals) (let* ((name (car local)) (used-p (find-use name body))) @@ -820,7 +822,7 @@ (return-from precompile-flet/labels (precompile1 new-form)))))) (list* (car form) (precompile-local-functions locals) - (mapcar #'precompile1 body)))) + body))) (defun precompile-function (form) (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA)) From ehuelsmann at common-lisp.net Sun Jun 27 19:48:43 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 27 Jun 2010 15:48:43 -0400 Subject: [armedbear-cvs] r12769 - in branches/generic-class-file/abcl: . src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jun 27 15:48:41 2010 New Revision: 12769 Log: README.BRANCH update, pool-management and method finalization. Modified: branches/generic-class-file/abcl/README.BRANCH branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (contents, props changed) Modified: branches/generic-class-file/abcl/README.BRANCH ============================================================================== --- branches/generic-class-file/abcl/README.BRANCH (original) +++ branches/generic-class-file/abcl/README.BRANCH Sun Jun 27 15:48:41 2010 @@ -38,7 +38,14 @@ Design ====== +The code uses structures and structure inclusion for the class file and +class file attributes. Each attribute type has an associated specific +finalizer and writer function. This should allow for future ease of +extension. +There are three phases in the design. Read about that in the file itself. + +Structure inclusion is used as a means of single inheritance. Status Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Jun 27 15:48:41 2010 @@ -1,638 +1,656 @@ -;;; jvm-class-file.lisp -;;; -;;; Copyright (C) 2010 Erik Huelsmann -;;; $Id: compiler-pass2.lisp 12311 2009-12-28 23:11:35Z ehuelsmann $ -;;; -;;; 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. - -(in-package "JVM") - -#| - -The general design of the class-file writer is to have generic -- human readable - representations of the class being generated -during the construction and manipulation phases. - -After completing the creation/manipulation of the class, all its -components will be finalized. This process translates readable -(e.g. string) representations to indices to be stored on disc. - -The only thing to be done after finalization is sending the -output to a stream ("writing"). - - -Finalization happens highest-level first. As an example, take a -method with exception handlers. The exception handlers are stored -as attributes in the class file structure. They are children of the -method's Code attribute. In this example, the body of the Code -attribute (the higher level) gets finalized before the attributes. -The reason to do so is that the exceptions need to refer to labels -(offsets) in the Code segment. - - -|# - - -(defun map-primitive-type (type) - (case type - (:int "I") - (:long "J") - (:float "F") - (:double "D") - (:boolean "Z") - (:char "C") - (:byte "B") - (:short "S") - (:void "V"))) - - -#| - -The `class-name' facility helps to abstract from "this instruction takes -a reference" and "this instruction takes a class name". We simply pass -the class name around and the instructions themselves know which -representation to use. - -|# - -(defstruct (class-name (:conc-name class-) - (:constructor %make-class-name)) - name-internal - ref - array-ref) - -(defun make-class-name (name) - (setf name (substitute #\/ #\. name)) - (%make-class-name :name-internal name - :ref (concatenate 'string "L" name ";") - :array-ref (concatenate 'string "[L" name ";"))) - -(defmacro define-class-name (symbol java-dotted-name &optional documentation) - `(defconstant ,symbol (make-class-name ,java-dotted-name) - ,documentation)) - -(define-class-name +!java-object+ "java.lang.Object") -(define-class-name +!java-string+ "java.lang.String") -(define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject") -(define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString") -(define-class-name +!lisp+ "org.armedbear.lisp.Lisp") -(define-class-name +!lisp-nil+ "org.armedbear.lisp.Nil") -(define-class-name +!lisp-class+ "org.armedbear.lisp.LispClass") -(define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol") -(define-class-name +!lisp-thread+ "org.armedbear.lisp.LispThread") -(define-class-name +!lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding") -(define-class-name +!lisp-integer+ "org.armedbear.lisp.Integer") -(define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum") -(define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum") -(define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat") -(define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat") -(define-class-name +!lisp-cons+ "org.armedbear.lisp.Cons") -(define-class-name +!lisp-load+ "org.armedbear.lisp.Load") -(define-class-name +!lisp-character+ "org.armedbear.lisp.Character") -(define-class-name +!lisp-simple-vector+ "org.armedbear.lisp.SimpleVector") -(define-class-name +!lisp-abstract-string+ "org.armedbear.lisp.AbstractString") -(define-class-name +!lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector") -(define-class-name +!lisp-abstract-bit-vector+ - "org.armedbear.lisp.AbstractBitVector") -(define-class-name +!lisp-environment+ "org.armedbear.lisp.Environment") -(define-class-name +!lisp-special-binding+ "org.armedbear.lisp.SpecialBinding") -(define-class-name +!lisp-special-binding-mark+ - "org.armedbear.lisp.SpecialBindingMark") -(define-class-name +!lisp-throw+ "org.armedbear.lisp.Throw") -(define-class-name +!lisp-return+ "org.armedbear.lisp.Return") -(define-class-name +!lisp-go+ "org.armedbear.lisp.Go") -(define-class-name +!lisp-primitive+ "org.armedbear.lisp.Primitive") -(define-class-name +!lisp-compiled-closure+ - "org.armedbear.lisp.CompiledClosure") -(define-class-name +!lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable") -(define-class-name +!lisp-package+ "org.armedbear.lisp.Package") -(define-class-name +!lisp-readtable+ "org.armedbear.lisp.Readtable") -(define-class-name +!lisp-stream+ "org.armedbear.lisp.Stream") -(define-class-name +!lisp-closure+ "org.armedbear.lisp.Closure") -(define-class-name +!lisp-closure-parameter+ - "org.armedbear.lisp.Closure$Parameter") -(define-class-name +!fasl-loader+ "org.armedbear.lisp.FaslClassLoader") - - -(defun descriptor (method-name return-type &rest argument-types) - (format nil "~A(~{~A~}~A)" method-name - (mapcar #'(lambda (arg-type) - (if (keywordp arg-type) - (map-primitive-type arg-type) - (class-ref arg-type))) - argument-types) - (if (keywordp return-type) - (map-primitive-type return-type) - (class-name-internal return-type)))) - - - - - -(defstruct pool - (count 1) ;; #### why count 1??? - entries-list - (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0))) - -(defstruct constant - tag - index) - -(defparameter +constant-type-map+ - '((:class 7 1) - (:field-ref 9 1) - (:method-ref 10 1) - ;; (:interface-method-ref 11) - (:string 8 1) - (:integer 3 1) - (:float 4 1) - (:long 5 2) - (:double 6 2) - (:name-and-type 12 1) - (:utf8 1 1))) - -(defstruct (constant-class (:include constant - (tag 7))) - name) - -(defstruct (constant-member-ref (:include constant)) - class - name/type) - -(defstruct (constant-string (:constructor make-constant-string (value-index)) - (:include constant - (tag 8))) - value-index) ;;; #### is this the value or the value index??? - -(defstruct (constant-float/int (:include constant)) - value) - -(defstruct (constant-double/long (:include constant)) - value) - -(defstruct (constant-name/type (:include constant)) - name-index - descriptor-index) - -(defstruct (constant-utf8 (:include constant)) - value) - - -;; Need to add pool/constant creation addition routines here; -;; all routines have 2 branches: return existing or push new. - -(defun pool-add-string (pool string) - (let ((entry (gethash (pool-entries string)))) - (unless entry - (setf entry (make-constant-string (pool-count pool) string)) - (push entry (pool-entries-list pool)) - (incf (pool-count pool))) - (constant-index entry))) - - - -(defstruct (class-file (:constructor %make-class-file)) - constants - access-flags - class - superclass - ;; interfaces - fields - methods - attributes - ) - -(defun class-add-field (class field) - (push field (class-file-fields class))) - -(defun class-field (class name) - (find name (class-file-fields class) - :test #'string= :key #'field-name)) - -(defun class-add-method (class method) - (push method (class-file-methods class))) - -(defun class-methods-by-name (class name) - (remove (map-method-name name) (class-file-methods class) - :test-not #'string= :key #'method-name)) - -(defun class-method (class descriptor) - (find descriptor (class-file-methods class) - :test #'string= :key #'method-name)) - - -(defun finalize-class-file (class) - - ;; constant pool contains constants finalized on addition; - ;; no need for additional finalization - - (setf (class-file-access-flags class) - (map-flags (class-file-access-flags class))) - ;; (finalize-class-name ) - ;; (finalize-interfaces) - (dolist (field (class-file-fields class)) - (finalize-field field class)) - (dolist (method (class-file-methods class)) - (finalize-method method class)) - ;; top-level attributes (no parent attributes to refer to) - (finalize-attributes (class-file-attributes class) nil class) - -) - -(defun !write-class-file (class stream) - ;; all components need to finalize themselves: - ;; the constant pool needs to be complete before we start - ;; writing our output. - - ;; header - (write-u4 #xCAFEBABE stream) - (write-u2 3 stream) - (write-u2 45 stream) - - ;; constants pool - (write-constants (class-file-constants class) stream) - ;; flags - (write-u2 (class-file-access-flags class) stream) - ;; class name - (write-u2 (class-file-class class) stream) - ;; superclass - (write-u2 (class-file-superclass class) stream) - - ;; interfaces - (write-u2 0 stream) - - ;; fields - (write-u2 (length (class-file-fields class)) stream) - (dolist (field (class-file-fields class)) - (!write-field field stream)) - - ;; methods - (write-u2 (length (class-file-methods class)) stream) - (dolist (method (class-file-methods class)) - (!write-method method stream)) - - ;; attributes - (write-attributes (class-file-attributes class) stream)) - -(defun write-constants (constants stream) - (write-u2 (pool-count constants) stream) - (dolist (entry (reverse (pool-entries-list constants))) - (let ((tag (constant-tag entry))) - (write-u1 tag stream) - (case tag - (1 ; UTF8 - (write-utf8 (constant-utf8-value entry) stream)) - ((3 4) ; int - (write-u4 (constant-float/int-value entry) stream)) - ((5 6) ; long double - (write-u4 (second entry) stream) - (write-u4 (third entry) stream)) - ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType - (write-u2 (second entry) stream) - (write-u2 (third entry) stream)) - ((7 8) ; class string - (write-u2 (constant-class-name entry) stream)) - (t - (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))) - -#| - -ABCL doesn't use interfaces, so don't implement it here at this time - -(defstruct interface) - -|# - - -(defparameter +access-flags-map+ - '((:public #x0001) - (:private #x0002) - (:protected #x0004) - (:static #x0008) - (:final #x0010) - (:volatile #x0040) - (:synchronized #x0020) - (:transient #x0080) - (:native #x0100) - (:abstract #x0400) - (:strict #x0800))) - -(defun map-flags (flags) - (reduce #'(lambda (x y) - (logior (or (when (member (car x) flags) - (second x)) - 0) y) - (logior (or ))) - :initial-value 0)) - -(defstruct (field (:constructor %make-field)) - access-flags - name - descriptor - attributes - ) - -(defun make-field (name type &key (flags '(:public))) - (%make-field :access-flags flags - :name name - :descriptor (map-primitive-type type))) - -(defun add-field-attribute (field attribute) - (push attribute (field-attributes field))) - - -(defun finalize-field (field class) - (declare (ignore class field)) - (error "Not implemented")) - -(defun !write-field (field stream) - (declare (ignore field stream)) - (error "Not implemented")) - - -(defstruct (method (:constructor %!make-method)) - access-flags - name - descriptor - attributes - arg-count ;; not in the class file, - ;; but required for setting up CODE attribute - ) - - -(defun map-method-name (name) - (cond - ((eq name :class-constructor) - "") - ((eq name :constructor) - "") - (t name))) - -(defun !make-method-descriptor (name return &rest args) - (apply #'concatenate (append (list 'string (map-method-name name) "(") - (mapcar #'map-primitive-type args) - (list ")" return)))) - -(defun !make-method (name return args &key (flags '(:public))) - (setf name (map-method-name name)) - (%make-method :descriptor (apply #'make-method-descriptor - name return args) - :access-flags flags - :name name - :arg-count (if (member :static flags) - (length args) - (1+ (length args))))) ;; implicit 'this' - -(defun method-add-attribute (method attribute) - (push attribute (method-attributes method))) - -(defun method-attribute (method name) - (find name (method-attributes method) - :test #'string= :key #'attribute-name)) - - -(defun finalize-method (method class) - (declare (ignore method class)) - (error "Not implemented")) - - -(defun !write-method (method stream) - (declare (ignore method stream)) - (error "Not implemented")) - -(defstruct attribute - name - - ;; not in the class file: - finalizer ;; function of 3 arguments: the attribute, parent and class-file - writer ;; function of 2 arguments: the attribute and the output stream - ) - -(defun finalize-attributes (attributes att class) - (dolist (attribute attributes) - ;; assure header: make sure 'name' is in the pool - (setf (attribute-name attribute) - (pool-add-string (class-file-constants class) - (attribute-name attribute))) - ;; we're saving "root" attributes: attributes which have no parent - (funcall (attribute-finalizer attribute) attribute att class))) - -(defun write-attributes (attributes stream) - (write-u2 (length attributes) stream) - (dolist (attribute attributes) - (write-u2 (attribute-name attribute) stream) - ;; set up a bulk catcher for (UNSIGNED-BYTE 8) - ;; since we need to know the attribute length (excluding the header) - (let ((local-stream (sys::%make-byte-array-output-stream))) - (funcall (attribute-writer attribute) attribute local-stream) - (let ((array (sys::%get-output-stream-array local-stream))) - (write-u2 (length array) stream) - (write-sequence array stream))))) - - - -(defstruct (code-attribute (:conc-name code-) - (:include attribute - (name "Code") - (finalizer #'!finalize-code) - (writer #'!write-code)) - (:constructor %make-code-attribute)) - max-stack - max-locals - code - attributes - ;; labels contains offsets into the code array after it's finalized - (labels (make-hash-table :test #'eq)) - - ;; fields not in the class file start here - current-local ;; used for handling nested WITH-CODE-TO-METHOD blocks - ) - - -(defun code-label-offset (code label) - (gethash label (code-labels code))) - -(defun (setf code-label-offset) (offset code label) - (setf (gethash label (code-labels code)) offset)) - -(defun !finalize-code (code class) - (let ((c (coerce (resolve-instructions (code-code code)) 'vector))) - (setf (code-max-stack code) (analyze-stack c) - (code-code code) (code-bytes c))) - (finalize-attributes (code-attributes code) code class)) - -(defun !write-code (code stream) - (write-u2 (code-max-stack code) stream) - (write-u2 (code-max-locals code) stream) - (let ((code-array (code-code code))) - (write-u4 (length code-array) stream) - (dotimes (i (length code-array)) - (write-u1 (svref code-array i) stream))) - (write-attributes (code-attributes code) stream)) - -(defun make-code-attribute (method) - (%make-code-attribute :max-locals (method-arg-count method))) - -(defun code-add-attribute (code attribute) - (push attribute (code-attributes code))) - -(defun code-attribute (code name) - (find name (code-attributes code) - :test #'string= :key #'attribute-name)) - - - -(defvar *current-code-attribute*) - -(defun save-code-specials (code) - (setf (code-code code) *code* - (code-max-locals code) *registers-allocated* - (code-exception-handlers code) *handlers* - (code-current-local code) *register*)) - -(defun restore-code-specials (code) - (setf *code* (code-code code) - *registers-allocated* (code-max-locals code) - *register* (code-current-local code))) - -(defmacro with-code-to-method ((method &key safe-nesting) &body body) - (let ((m (gensym)) - (c (gensym))) - `(progn - ,@(when safe-nesting - `((when *current-code-attribute* - (save-code-specials *current-code-attribute*)))) - (let* ((,m ,method) - (,c (method-attribute ,m "Code")) - (*code* (code-code ,c)) - (*registers-allocated* (code-max-locals ,c)) - (*register* (code-current-local ,c)) - (*current-code-attribute* ,c)) - , at body - (setf (code-code ,c) *code* - (code-exception-handlers ,c) *handlers* - (code-max-locals ,c) *registers-allocated*)) - ,@(when safe-nesting - `((when *current-code-attribute* - (restore-code-specials *current-code-attribute*))))))) - -(defstruct (exceptions-attribute (:constructor make-exceptions) - (:conc-name exceptions-) - (:include attribute - (name "Exceptions") - (finalizer #'finalize-exceptions) - (writer #'write-exceptions))) - exceptions) - -(defun finalize-exceptions (exceptions code class) - (dolist (exception (exceptions-exceptions exceptions)) - ;; no need to finalize `catch-type': it's already the index required - (setf (exception-start-pc exception) - (code-label-offset code (exception-start-pc exception)) - (exception-end-pc exception) - (code-label-offset code (exception-end-pc exception)) - (exception-handler-pc exception) - (code-label-offset code (exception-handler-pc exception)) - (exception-catch-type exception) - (pool-add-string (class-file-constants class) - (exception-catch-type exception)))) - ;;(finalize-attributes (exceptions-attributes exception) exceptions class) - ) - - -(defun write-exceptions (exceptions stream) - ; number of entries - (write-u2 (length (exceptions-exceptions exceptions)) stream) - (dolist (exception (exceptions-exceptions exceptions)) - (write-u2 (exception-start-pc exception) stream) - (write-u2 (exception-end-pc exception) stream) - (write-u2 (exception-handler-pc exception) stream) - (write-u2 (exception-catch-type exception) stream))) - -(defun code-add-exception (code start end handler type) - (when (null (code-attribute code "Exceptions")) - (code-add-attribute code (make-exceptions))) - (push (make-exception :start-pc start - :end-pc end - :handler-pc handler - :catch-type type) - (exceptions-exceptions (code-attribute code "Exceptions")))) - -(defstruct exception - start-pc ;; label target - end-pc ;; label target - handler-pc ;; label target - catch-type ;; a string for a specific type, or NIL for all - ) - -(defstruct (source-file-attribute (:conc-name source-) - (:include attribute - (name "SourceFile"))) - filename) - -(defstruct (line-numbers-attribute (:include attribute - (name "LineNumberTable"))) - line-numbers) - -(defstruct line-number - start-pc - line) - -(defstruct (local-variables-attribute (:conc-name local-var-) - (:include attribute - (name "LocalVariableTable"))) - locals) - -(defstruct (local-variable (:conc-name local-)) - start-pc - length - name - descriptor - index) - -#| - -;; this is the minimal sequence we need to support: - -;; create a class file structure -;; add methods -;; add code to the methods, switching from one method to the other -;; finalize the methods, one by one -;; write the class file - -to support the sequence above, we probably need to -be able to - -- find methods by signature -- find the method's code attribute -- add code to the code attribute -- finalize the code attribute contents (blocking it for further addition) -- - - -|# - +;;; jvm-class-file.lisp +;;; +;;; Copyright (C) 2010 Erik Huelsmann +;;; $Id$ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 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. + +(in-package "JVM") + +#| + +The general design of the class-file writer is to have generic +- human readable - representations of the class being generated +during the construction and manipulation phases. + +After completing the creation/manipulation of the class, all its +components will be finalized. This process translates readable +(e.g. string) representations to indices to be stored on disc. + +The only thing to be done after finalization is sending the +output to a stream ("writing"). + + +Finalization happens highest-level first. As an example, take a +method with exception handlers. The exception handlers are stored +as attributes in the class file structure. They are children of the +method's Code attribute. In this example, the body of the Code +attribute (the higher level) gets finalized before the attributes. +The reason to do so is that the exceptions need to refer to labels +(offsets) in the Code segment. + + +|# + + +(defun map-primitive-type (type) + (case type + (:int "I") + (:long "J") + (:float "F") + (:double "D") + (:boolean "Z") + (:char "C") + (:byte "B") + (:short "S") + ((nil :void) "V"))) + + +#| + +The `class-name' facility helps to abstract from "this instruction takes +a reference" and "this instruction takes a class name". We simply pass +the class name around and the instructions themselves know which +representation to use. + +|# + +(defstruct (class-name (:conc-name class-) + (:constructor %make-class-name)) + name-internal + ref + array-ref) + +(defun make-class-name (name) + (setf name (substitute #\/ #\. name)) + (%make-class-name :name-internal name + :ref (concatenate 'string "L" name ";") + :array-ref (concatenate 'string "[L" name ";"))) + +(defmacro define-class-name (symbol java-dotted-name &optional documentation) + `(defconstant ,symbol (make-class-name ,java-dotted-name) + ,documentation)) + +(define-class-name +!java-object+ "java.lang.Object") +(define-class-name +!java-string+ "java.lang.String") +(define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject") +(define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString") +(define-class-name +!lisp+ "org.armedbear.lisp.Lisp") +(define-class-name +!lisp-nil+ "org.armedbear.lisp.Nil") +(define-class-name +!lisp-class+ "org.armedbear.lisp.LispClass") +(define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol") +(define-class-name +!lisp-thread+ "org.armedbear.lisp.LispThread") +(define-class-name +!lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding") +(define-class-name +!lisp-integer+ "org.armedbear.lisp.Integer") +(define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum") +(define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum") +(define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat") +(define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat") +(define-class-name +!lisp-cons+ "org.armedbear.lisp.Cons") +(define-class-name +!lisp-load+ "org.armedbear.lisp.Load") +(define-class-name +!lisp-character+ "org.armedbear.lisp.Character") +(define-class-name +!lisp-simple-vector+ "org.armedbear.lisp.SimpleVector") +(define-class-name +!lisp-abstract-string+ "org.armedbear.lisp.AbstractString") +(define-class-name +!lisp-abstract-vector+ "org.armedbear.lisp.AbstractVector") +(define-class-name +!lisp-abstract-bit-vector+ + "org.armedbear.lisp.AbstractBitVector") +(define-class-name +!lisp-environment+ "org.armedbear.lisp.Environment") +(define-class-name +!lisp-special-binding+ "org.armedbear.lisp.SpecialBinding") +(define-class-name +!lisp-special-binding-mark+ + "org.armedbear.lisp.SpecialBindingMark") +(define-class-name +!lisp-throw+ "org.armedbear.lisp.Throw") +(define-class-name +!lisp-return+ "org.armedbear.lisp.Return") +(define-class-name +!lisp-go+ "org.armedbear.lisp.Go") +(define-class-name +!lisp-primitive+ "org.armedbear.lisp.Primitive") +(define-class-name +!lisp-compiled-closure+ + "org.armedbear.lisp.CompiledClosure") +(define-class-name +!lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable") +(define-class-name +!lisp-package+ "org.armedbear.lisp.Package") +(define-class-name +!lisp-readtable+ "org.armedbear.lisp.Readtable") +(define-class-name +!lisp-stream+ "org.armedbear.lisp.Stream") +(define-class-name +!lisp-closure+ "org.armedbear.lisp.Closure") +(define-class-name +!lisp-closure-parameter+ + "org.armedbear.lisp.Closure$Parameter") +(define-class-name +!fasl-loader+ "org.armedbear.lisp.FaslClassLoader") + + +(defun internal-field-type (field-type) + (if (keywordp field-type) + (map-primitive-type field-type) + (class-name-internal field-type))) + +(defun internal-field-ref (field-type) + (if (keywordp field-type) + (map-primitive-type field-type) + (class-ref field-type))) + +(defun descriptor (return-type &rest argument-types) + (format nil "(~{~A~}~A)" (mapcar #'internal-field-ref argument-types) + (internal-field-type return-type))) + + +(defstruct pool + (count 1) ;; "A constant pool entry is considered valid if it has + ;; an index greater than 0 (zero) and less than pool-count" + entries-list + ;; the entries hash stores raw values, except in case of string and + ;; utf8, because both are string values + (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0))) + +(defstruct constant + tag + index) + +(defparameter +constant-type-map+ + '((:class 7 1) + (:field-ref 9 1) + (:method-ref 10 1) + ;; (:interface-method-ref 11) + (:string 8 1) + (:integer 3 1) + (:float 4 1) + (:long 5 2) + (:double 6 2) + (:name-and-type 12 1) + (:utf8 1 1))) + +(defstruct (constant-class (:include constant + (tag 7))) + name) + +(defstruct (constant-member-ref (:include constant)) + class + name/type) + +(defstruct (constant-string (:constructor make-constant-string + (index value-index)) + (:include constant + (tag 8))) + value-index) ;;; #### is this the value or the value index??? + +(defstruct (constant-float/int (:include constant)) + value) + +(defstruct (constant-double/long (:include constant)) + value) + +(defstruct (constant-name/type (:include constant)) + name-index + descriptor-index) + +(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value)) + (:include constant + (tag 11))) + value) + + +(defun pool-add-string (pool string) + (let ((entry (gethash (cons 8 string) ;; 8 == string-tag + (pool-entries pool)))) + (unless entry + (setf entry (make-constant-string (pool-add-utf8 pool string)) + (gethash (cons 8 string) (pool-entries pool)) entry) + (incf (pool-count pool)) + (push entry (pool-entries-list pool))) + (constant-index entry))) + +(defun pool-add-utf8 (pool utf8-as-string) + (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8 + (pool-entries pool)))) + (unless entry + (setf entry (make-constant-utf8 (pool-count pool) utf8-as-string) + (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry) + (incf (pool-count pool)) + (push entry (pool-entries-list pool))) + (constant-index entry))) + +(defstruct (class-file (:constructor %make-class-file)) + constants + access-flags + class + superclass + ;; interfaces + fields + methods + attributes + ) + +(defun class-add-field (class field) + (push field (class-file-fields class))) + +(defun class-field (class name) + (find name (class-file-fields class) + :test #'string= :key #'field-name)) + +(defun class-add-method (class method) + (push method (class-file-methods class))) + +(defun class-methods-by-name (class name) + (remove (map-method-name name) (class-file-methods class) + :test-not #'string= :key #'method-name)) + +(defun class-method (class descriptor) + (find descriptor (class-file-methods class) + :test #'string= :key #'method-name)) + + +(defun finalize-class-file (class) + + ;; constant pool contains constants finalized on addition; + ;; no need for additional finalization + + (setf (class-file-access-flags class) + (map-flags (class-file-access-flags class))) + ;; (finalize-class-name ) + ;; (finalize-interfaces) + (dolist (field (class-file-fields class)) + (finalize-field field class)) + (dolist (method (class-file-methods class)) + (finalize-method method class)) + ;; top-level attributes (no parent attributes to refer to) + (finalize-attributes (class-file-attributes class) nil class) + +) + +(defun !write-class-file (class stream) + ;; all components need to finalize themselves: + ;; the constant pool needs to be complete before we start + ;; writing our output. + + ;; header + (write-u4 #xCAFEBABE stream) + (write-u2 3 stream) + (write-u2 45 stream) + + ;; constants pool + (write-constants (class-file-constants class) stream) + ;; flags + (write-u2 (class-file-access-flags class) stream) + ;; class name + (write-u2 (class-file-class class) stream) + ;; superclass + (write-u2 (class-file-superclass class) stream) + + ;; interfaces + (write-u2 0 stream) + + ;; fields + (write-u2 (length (class-file-fields class)) stream) + (dolist (field (class-file-fields class)) + (!write-field field stream)) + + ;; methods + (write-u2 (length (class-file-methods class)) stream) + (dolist (method (class-file-methods class)) + (!write-method method stream)) + + ;; attributes + (write-attributes (class-file-attributes class) stream)) + +(defun write-constants (constants stream) + (write-u2 (pool-count constants) stream) + (dolist (entry (reverse (pool-entries-list constants))) + (let ((tag (constant-tag entry))) + (write-u1 tag stream) + (case tag + (1 ; UTF8 + (write-utf8 (constant-utf8-value entry) stream)) + ((3 4) ; int + (write-u4 (constant-float/int-value entry) stream)) + ((5 6) ; long double + (write-u4 (second entry) stream) + (write-u4 (third entry) stream)) + ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType + (write-u2 (second entry) stream) + (write-u2 (third entry) stream)) + ((7 8) ; class string + (write-u2 (constant-class-name entry) stream)) + (t + (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))) + +#| + +ABCL doesn't use interfaces, so don't implement it here at this time + +(defstruct interface) + +|# + + +(defparameter +access-flags-map+ + '((:public #x0001) + (:private #x0002) + (:protected #x0004) + (:static #x0008) + (:final #x0010) + (:volatile #x0040) + (:synchronized #x0020) + (:transient #x0080) + (:native #x0100) + (:abstract #x0400) + (:strict #x0800))) + +(defun map-flags (flags) + (reduce #'(lambda (x y) + (logior (or (when (member (car x) flags) + (second x)) + 0) y) + (logior (or ))) + :initial-value 0)) + +(defstruct (field (:constructor %make-field)) + access-flags + name + descriptor + attributes + ) + +(defun make-field (name type &key (flags '(:public))) + (%make-field :access-flags flags + :name name + :descriptor (map-primitive-type type))) + +(defun add-field-attribute (field attribute) + (push attribute (field-attributes field))) + + +(defun finalize-field (field class) + (declare (ignore class field)) + (error "Not implemented")) + +(defun !write-field (field stream) + (declare (ignore field stream)) + (error "Not implemented")) + + +(defstruct (method (:constructor %!make-method)) + access-flags + name + descriptor + attributes + arg-count ;; not in the class file, + ;; but required for setting up CODE attribute + ) + + +(defun map-method-name (name) + (cond + ((eq name :class-constructor) + "") + ((eq name :constructor) + "") + (t name))) + +(defun !make-method-descriptor (name return &rest args) + (apply #'concatenate (append (list 'string (map-method-name name) "(") + (mapcar #'map-primitive-type args) + (list ")" return)))) + +(defun !make-method (name return args &key (flags '(:public))) + (setf name (map-method-name name)) + (%make-method :descriptor (apply #'make-method-descriptor + name return args) + :access-flags flags + :name name + :arg-count (if (member :static flags) + (length args) + (1+ (length args))))) ;; implicit 'this' + +(defun method-add-attribute (method attribute) + (push attribute (method-attributes method))) + +(defun method-attribute (method name) + (find name (method-attributes method) + :test #'string= :key #'attribute-name)) + + +(defun finalize-method (method class) + (setf (method-access-flags method) + (map-flags (method-access-flags method)) + (method-descriptor method) + (pool-add-utf8 (apply #'descriptor (method-descriptor method))) + (method-name method) + (pool-add-utf8 (map-method-name (method-name method)))) + (finalize-attributes attributes nil class)) + + +(defun !write-method (method stream) + (declare (ignore method stream)) + (error "Not implemented")) + +(defstruct attribute + name + + ;; not in the class file: + finalizer ;; function of 3 arguments: the attribute, parent and class-file + writer ;; function of 2 arguments: the attribute and the output stream + ) + +(defun finalize-attributes (attributes att class) + (dolist (attribute attributes) + ;; assure header: make sure 'name' is in the pool + (setf (attribute-name attribute) + (pool-add-string (class-file-constants class) + (attribute-name attribute))) + ;; we're saving "root" attributes: attributes which have no parent + (funcall (attribute-finalizer attribute) attribute att class))) + +(defun write-attributes (attributes stream) + (write-u2 (length attributes) stream) + (dolist (attribute attributes) + (write-u2 (attribute-name attribute) stream) + ;; set up a bulk catcher for (UNSIGNED-BYTE 8) + ;; since we need to know the attribute length (excluding the header) + (let ((local-stream (sys::%make-byte-array-output-stream))) + (funcall (attribute-writer attribute) attribute local-stream) + (let ((array (sys::%get-output-stream-array local-stream))) + (write-u2 (length array) stream) + (write-sequence array stream))))) + + + +(defstruct (code-attribute (:conc-name code-) + (:include attribute + (name "Code") + (finalizer #'!finalize-code) + (writer #'!write-code)) + (:constructor %make-code-attribute)) + max-stack + max-locals + code + attributes + ;; labels contains offsets into the code array after it's finalized + (labels (make-hash-table :test #'eq)) + + ;; fields not in the class file start here + current-local ;; used for handling nested WITH-CODE-TO-METHOD blocks + ) + + +(defun code-label-offset (code label) + (gethash label (code-labels code))) + +(defun (setf code-label-offset) (offset code label) + (setf (gethash label (code-labels code)) offset)) + +(defun !finalize-code (code class) + (let ((c (coerce (resolve-instructions (code-code code)) 'vector))) + (setf (code-max-stack code) (analyze-stack c) + (code-code code) (code-bytes c))) + (finalize-attributes (code-attributes code) code class)) + +(defun !write-code (code stream) + (write-u2 (code-max-stack code) stream) + (write-u2 (code-max-locals code) stream) + (let ((code-array (code-code code))) + (write-u4 (length code-array) stream) + (dotimes (i (length code-array)) + (write-u1 (svref code-array i) stream))) + (write-attributes (code-attributes code) stream)) + +(defun make-code-attribute (method) + (%make-code-attribute :max-locals (method-arg-count method))) + +(defun code-add-attribute (code attribute) + (push attribute (code-attributes code))) + +(defun code-attribute (code name) + (find name (code-attributes code) + :test #'string= :key #'attribute-name)) + + + +(defvar *current-code-attribute*) + +(defun save-code-specials (code) + (setf (code-code code) *code* + (code-max-locals code) *registers-allocated* + (code-exception-handlers code) *handlers* + (code-current-local code) *register*)) + +(defun restore-code-specials (code) + (setf *code* (code-code code) + *registers-allocated* (code-max-locals code) + *register* (code-current-local code))) + +(defmacro with-code-to-method ((method &key safe-nesting) &body body) + (let ((m (gensym)) + (c (gensym))) + `(progn + ,@(when safe-nesting + `((when *current-code-attribute* + (save-code-specials *current-code-attribute*)))) + (let* ((,m ,method) + (,c (method-attribute ,m "Code")) + (*code* (code-code ,c)) + (*registers-allocated* (code-max-locals ,c)) + (*register* (code-current-local ,c)) + (*current-code-attribute* ,c)) + , at body + (setf (code-code ,c) *code* + (code-exception-handlers ,c) *handlers* + (code-max-locals ,c) *registers-allocated*)) + ,@(when safe-nesting + `((when *current-code-attribute* + (restore-code-specials *current-code-attribute*))))))) + +(defstruct (exceptions-attribute (:constructor make-exceptions) + (:conc-name exceptions-) + (:include attribute + (name "Exceptions") + (finalizer #'finalize-exceptions) + (writer #'write-exceptions))) + exceptions) + +(defun finalize-exceptions (exceptions code class) + (dolist (exception (exceptions-exceptions exceptions)) + ;; no need to finalize `catch-type': it's already the index required + (setf (exception-start-pc exception) + (code-label-offset code (exception-start-pc exception)) + (exception-end-pc exception) + (code-label-offset code (exception-end-pc exception)) + (exception-handler-pc exception) + (code-label-offset code (exception-handler-pc exception)) + (exception-catch-type exception) + (pool-add-string (class-file-constants class) + (exception-catch-type exception)))) + ;;(finalize-attributes (exceptions-attributes exception) exceptions class) + ) + + +(defun write-exceptions (exceptions stream) + ; number of entries + (write-u2 (length (exceptions-exceptions exceptions)) stream) + (dolist (exception (exceptions-exceptions exceptions)) + (write-u2 (exception-start-pc exception) stream) + (write-u2 (exception-end-pc exception) stream) + (write-u2 (exception-handler-pc exception) stream) + (write-u2 (exception-catch-type exception) stream))) + +(defun code-add-exception (code start end handler type) + (when (null (code-attribute code "Exceptions")) + (code-add-attribute code (make-exceptions))) + (push (make-exception :start-pc start + :end-pc end + :handler-pc handler + :catch-type type) + (exceptions-exceptions (code-attribute code "Exceptions")))) + +(defstruct exception + start-pc ;; label target + end-pc ;; label target + handler-pc ;; label target + catch-type ;; a string for a specific type, or NIL for all + ) + +(defstruct (source-file-attribute (:conc-name source-) + (:include attribute + (name "SourceFile"))) + filename) + +(defstruct (line-numbers-attribute (:include attribute + (name "LineNumberTable"))) + line-numbers) + +(defstruct line-number + start-pc + line) + +(defstruct (local-variables-attribute (:conc-name local-var-) + (:include attribute + (name "LocalVariableTable"))) + locals) + +(defstruct (local-variable (:conc-name local-)) + start-pc + length + name + descriptor + index) + +#| + +;; this is the minimal sequence we need to support: + +;; create a class file structure +;; add methods +;; add code to the methods, switching from one method to the other +;; finalize the methods, one by one +;; write the class file + +to support the sequence above, we probably need to +be able to + +- find methods by signature +- find the method's code attribute +- add code to the code attribute +- finalize the code attribute contents (blocking it for further addition) +- + + +|# + From ehuelsmann at common-lisp.net Sun Jun 27 20:28:52 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 27 Jun 2010 16:28:52 -0400 Subject: [armedbear-cvs] r12770 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jun 27 16:28:51 2010 New Revision: 12770 Log: Field/method finalization and writing. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Jun 27 16:28:51 2010 @@ -372,19 +372,27 @@ (defun make-field (name type &key (flags '(:public))) (%make-field :access-flags flags :name name - :descriptor (map-primitive-type type))) + :descriptor type)) (defun add-field-attribute (field attribute) (push attribute (field-attributes field))) (defun finalize-field (field class) - (declare (ignore class field)) - (error "Not implemented")) + (let ((pool (class-file-constants class))) + (setf (field-access-flags field) + (map-flags (field-access-flags field)) + (field-descriptor field) + (pool-add-utf8 pool (internal-field-type (field-descriptor field))) + (field-name field) + (pool-add-utf8 pool (field-name field)))) + (finalize-attributes (field-attributes field) nil class)) (defun !write-field (field stream) - (declare (ignore field stream)) - (error "Not implemented")) + (write-u2 (field-access-flags field) stream) + (write-u2 (field-name field) stream) + (write-u2 (field-descriptor field) stream) + (write-attributes (field-attributes field) stream)) (defstruct (method (:constructor %!make-method)) @@ -429,18 +437,21 @@ (defun finalize-method (method class) - (setf (method-access-flags method) - (map-flags (method-access-flags method)) - (method-descriptor method) - (pool-add-utf8 (apply #'descriptor (method-descriptor method))) - (method-name method) - (pool-add-utf8 (map-method-name (method-name method)))) - (finalize-attributes attributes nil class)) + (let ((pool (class-file-constants class))) + (setf (method-access-flags method) + (map-flags (method-access-flags method)) + (method-descriptor method) + (pool-add-utf8 pool (apply #'descriptor (method-descriptor method))) + (method-name method) + (pool-add-utf8 pool (map-method-name (method-name method))))) + (finalize-attributes (method-attributes method) nil class)) (defun !write-method (method stream) - (declare (ignore method stream)) - (error "Not implemented")) + (write-u2 (method-access-flags method) stream) + (write-u2 (method-name method) stream) + (write-u2 (method-descriptor method) stream) + (write-attributes (method-attributes method) stream)) (defstruct attribute name From astalla at common-lisp.net Sun Jun 27 21:38:10 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 27 Jun 2010 17:38:10 -0400 Subject: [armedbear-cvs] r12771 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Jun 27 17:38:09 2010 New Revision: 12771 Log: Fixed the handling of disassemble: functions store the *load-truename* they were loaded from, and use that to try to load bytecode for disassembly. If the loading fails, NIL is returned (it crashed hard before this fix). Modified: trunk/abcl/src/org/armedbear/lisp/Function.java Modified: trunk/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Function.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Function.java Sun Jun 27 17:38:09 2010 @@ -40,11 +40,20 @@ private LispObject propertyList = NIL; private int callCount; private int hotCount; - - protected Function() {} + /** + * The value of *load-truename* which was current when this function + * was loaded, used for fetching the class bytes in case of disassebly. + */ + private final LispObject loadedFrom; + + protected Function() { + LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValueNoThrow(); + loadedFrom = loadTruename != null ? loadTruename : NIL; + } public Function(String name) { + this(); if (name != null) { Symbol symbol = Symbol.addFunction(name.toUpperCase(), this); if (cold) @@ -55,6 +64,7 @@ public Function(Symbol symbol, String arglist) { + this(); symbol.setSymbolFunction(this); if (cold) symbol.setBuiltInFunction(true); @@ -64,6 +74,7 @@ public Function(Symbol symbol, String arglist, String docstring) { + this(); symbol.setSymbolFunction(this); if (cold) symbol.setBuiltInFunction(true); @@ -100,6 +111,7 @@ public Function(String name, Package pkg, boolean exported, String arglist, String docstring) { + this(); if (arglist instanceof String) setLambdaList(new SimpleString(arglist)); if (name != null) { @@ -120,11 +132,13 @@ public Function(LispObject name) { + this(); setLambdaName(name); } public Function(LispObject name, LispObject lambdaList) { + this(); setLambdaName(name); setLambdaList(lambdaList); } @@ -182,7 +196,22 @@ } else { ClassLoader c = getClass().getClassLoader(); if(c instanceof FaslClassLoader) { - return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this)); + final LispThread thread = LispThread.currentThread(); + SpecialBindingsMark mark = thread.markSpecialBindings(); + try { + thread.bindSpecial(Symbol.LOAD_TRUENAME, loadedFrom); + return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this)); + } catch(Throwable t) { + //This is because unfortunately getFunctionClassBytes uses + //Debug.assertTrue(false) to signal errors + if(t instanceof ControlTransfer) { + throw (ControlTransfer) t; + } else { + return NIL; + } + } finally { + thread.resetSpecialBindings(mark); + } } else { return NIL; } From ehuelsmann at common-lisp.net Sun Jun 27 22:07:05 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 27 Jun 2010 18:07:05 -0400 Subject: [armedbear-cvs] r12772 - branches/generic-class-file/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jun 27 18:07:04 2010 New Revision: 12772 Log: Implement most of the constant pool functionality. Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Jun 27 18:07:04 2010 @@ -137,6 +137,20 @@ "org.armedbear.lisp.Closure$Parameter") (define-class-name +!fasl-loader+ "org.armedbear.lisp.FaslClassLoader") +#| + +Lisp-side descriptor representation: + + - list: a list starting with a method return value, followed by + the argument types + - keyword: the primitive type associated with that keyword + - class-name structure instance: the class-ref value + +The latter two can be converted to a Java representation using +the `internal-field-ref' function, the former is to be fed to +`descriptor'. + +|# (defun internal-field-type (field-type) (if (keywordp field-type) @@ -178,27 +192,47 @@ (:name-and-type 12 1) (:utf8 1 1))) -(defstruct (constant-class (:include constant +(defstruct (constant-class (:constructor make-constant-class (index name-index)) + (:include constant (tag 7))) - name) + name-index) (defstruct (constant-member-ref (:include constant)) class name/type) -(defstruct (constant-string (:constructor make-constant-string - (index value-index)) +(defstruct (constant-string (:constructor + make-constant-string (index value-index)) (:include constant (tag 8))) value-index) ;;; #### is this the value or the value index??? -(defstruct (constant-float/int (:include constant)) +(defstruct (constant-float/int (:constructor + %make-constant-float/int (tag index value)) + (:include constant)) value) -(defstruct (constant-double/long (:include constant)) +(declaim (inline make-constant-float make-constant-int)) +(defun make-constant-float (index value) + (%make-constant-float/int 4 index value)) + +(defun make-constant-int (index value) + (%make-constant-float/int 3 index value)) + +(defstruct (constant-double/long (:constructor + %make-constant-double/long (tag index value)) + (:include constant)) value) -(defstruct (constant-name/type (:include constant)) +(declaim (inline make-constant-double make-constant-float)) +(defun make-constant-double (index value) + (%make-constant-double/long 6 index value)) + +(defun make-constant-long (index value) + (%make-constant-double/long 5 index value)) + +(defstruct (constant-name/type (:include constant + (tag 12))) name-index descriptor-index) @@ -208,13 +242,48 @@ value) +(defun pool-add-class (pool class) + ;; ### do we make class a string or class-name structure? + (let ((entry (gethash class (pool-entries pool)))) + (unless entry + (setf entry + (make-constant-class (incf (pool-count pool)) + (pool-add-utf8 pool + (class-name-internal class))) + (gethash class (pool-entries pool)) entry) + (push entry (pool-entries-list pool))) + (constant-index entry))) + +(defun pool-add-member-ref (pool class name type) + (let ((entry (gethash (acons name type class) (pool-entries pool)))) + (unless entry + (setf entry (make-constant-member-ref (incf (pool-count pool)) + (pool-add-class pool class) + (pool-add-name/type pool name type)) + (gethash (acons name type class) (pool-entries pool)) entry) + (push entry (pool-entries-list pool))) + (constant-index entry))) + (defun pool-add-string (pool string) (let ((entry (gethash (cons 8 string) ;; 8 == string-tag (pool-entries pool)))) (unless entry - (setf entry (make-constant-string (pool-add-utf8 pool string)) + (setf entry (make-constant-string (incf (pool-count pool)) + (pool-add-utf8 pool string)) (gethash (cons 8 string) (pool-entries pool)) entry) - (incf (pool-count pool)) + (push entry (pool-entries-list pool))) + (constant-index entry))) + +(defun pool-add-name/type (pool name type) + (let ((entry (gethash (cons name type) (pool-entries pool))) + (internal-type (if (listp type) + (apply #'descriptor type) + (internal-field-ref type)))) + (unless entry + (setf entry (make-constant-name/type (incf (pool-count pool)) + (pool-add-utf8 pool name) + (pool-add-utf8 pool internal-type)) + (gethash (cons name type) (pool-entries pool)) entry) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -222,9 +291,8 @@ (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8 (pool-entries pool)))) (unless entry - (setf entry (make-constant-utf8 (pool-count pool) utf8-as-string) + (setf entry (make-constant-utf8 (incf (pool-count pool)) utf8-as-string) (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry) - (incf (pool-count pool)) (push entry (pool-entries-list pool))) (constant-index entry))) @@ -328,7 +396,7 @@ (write-u2 (second entry) stream) (write-u2 (third entry) stream)) ((7 8) ; class string - (write-u2 (constant-class-name entry) stream)) + (write-u2 (constant-class-name-index entry) stream)) (t (error "write-constant-pool-entry unhandled tag ~D~%" tag))))))