From ehuelsmann at common-lisp.net Sat Oct 3 10:29:09 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 03 Oct 2009 06:29:09 -0400 Subject: [armedbear-cvs] r12169 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 3 06:29:02 2009 New Revision: 12169 Log: Sort out my thoughts: Add documentation. Modified: trunk/abcl/src/org/armedbear/lisp/Binding.java Modified: trunk/abcl/src/org/armedbear/lisp/Binding.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Binding.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Binding.java Sat Oct 3 06:29:02 2009 @@ -33,12 +33,44 @@ package org.armedbear.lisp; +/** Used by the environment to capture different kinds of bindings: + * tags, blocks, functions and variables. + * + */ // Package accessibility. final class Binding { + /** The symbol in case of a variable, block or + * non-SETF function binding, the tag (symbol or + * integer) in case of a tag binding or the cons + * in case of a SETF function binding + */ final LispObject symbol; + + /** Used only for tags. Refers to the environment + * relating to the tagbody in which the tag was created. + * + */ LispObject tagbody = null; + + /** The value bound. + * + * In case of a block binding, it holds the block identifier to be used + * with the Return to be thrown. + * + * In case of a tagbody, it holds the tail subforms of the tagbody, of + * which the tag is the first subform. + * + * In case of a function binding, it holds the function object. + * + * In case of a variable binding, it holds the value associated with the + * variable, unless specialp is true. + */ LispObject value; + + /** Only used for variable bindings. Indicates whether or not the value + * should be retrieved from the dynamic environment or from this binding. + */ boolean specialp; final Binding next; From ehuelsmann at common-lisp.net Sun Oct 4 12:37:33 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Oct 2009 08:37:33 -0400 Subject: [armedbear-cvs] r12170 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 4 08:37:29 2009 New Revision: 12170 Log: Don't throw Go and Return exceptions as means for non-local transfers of control, if the extent of the defining lexical context has ended. Throwing the exceptions anyway causes leaking of exceptions and possibly unwanted thread termination. Note: This commit breaks MISC.293A, MISC.293B and MISC.293C. This however is not a problem with this change, but exposes the fact that our compiler doesn't conform to the JVM specification of exception handlers: you can't expect the built-up stack to stay in place when the exception handler is invoked. Modified: trunk/abcl/src/org/armedbear/lisp/Binding.java trunk/abcl/src/org/armedbear/lisp/Do.java trunk/abcl/src/org/armedbear/lisp/Environment.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/dolist.java trunk/abcl/src/org/armedbear/lisp/dotimes.java Modified: trunk/abcl/src/org/armedbear/lisp/Binding.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Binding.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Binding.java Sun Oct 4 08:37:29 2009 @@ -47,11 +47,11 @@ */ final LispObject symbol; - /** Used only for tags. Refers to the environment - * relating to the tagbody in which the tag was created. + /** Used only for tags and blocks. Refers to the + * defining environment. * */ - LispObject tagbody = null; + Environment env = null; /** The value bound. * @@ -81,10 +81,10 @@ this.next = next; } - Binding(LispObject symbol, LispObject tagbody, + Binding(LispObject symbol, Environment env, LispObject value, Binding next) { this(symbol, value, next); - this.tagbody = tagbody; + this.env = env; } } Modified: trunk/abcl/src/org/armedbear/lisp/Do.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Do.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Do.java Sun Oct 4 08:37:29 2009 @@ -198,6 +198,7 @@ finally { thread.lastSpecialBinding = lastSpecialBinding; + ext.inactive = true; } } } Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Environment.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Environment.java Sun Oct 4 08:37:29 2009 @@ -39,6 +39,7 @@ private FunctionBinding lastFunctionBinding; private Binding blocks; private Binding tags; + public boolean inactive; //default value: false == active public Environment() {} @@ -165,9 +166,9 @@ return null; } - public void addBlock(LispObject tag, LispObject block) + public void addBlock(LispObject symbol, LispObject block) { - blocks = new Binding(tag, block, blocks); + blocks = new Binding(symbol, this, block, blocks); } public LispObject lookupBlock(LispObject symbol) @@ -182,9 +183,21 @@ return null; } - public void addTagBinding(LispObject tag, LispObject tagbody, LispObject code) + public Binding getBlockBinding(LispObject block) { - tags = new Binding(tag, tagbody, code, tags); + Binding binding = blocks; + while (binding != null) + { + if (binding.symbol == block) + return binding; + binding = binding.next; + } + return null; + } + + public void addTagBinding(LispObject tag, Environment env, LispObject code) + { + tags = new Binding(tag, env, code, tags); } public Binding getTagBinding(LispObject tag) Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Oct 4 08:37:29 2009 @@ -644,6 +644,87 @@ return localTags; } + /** Throws a Go exception to cause a non-local transfer + * of control event, after checking that the extent of + * the catching tagbody hasn't ended yet. + * + * This version is used by the compiler. + */ + public static final LispObject nonLocalGo(LispObject tagbody, + LispObject tag) + throws ConditionThrowable + { + if (tagbody == null) + return error(new ControlError("Unmatched tag " + + tag.writeToString() + + " for GO outside lexical extent.")); + + throw new Go(tagbody, tag); + } + + /** Throws a Go exception to cause a non-local transfer + * of control event, after checking that the extent of + * the catching tagbody hasn't ended yet. + * + * This version is used by the interpreter. + */ + public static final LispObject nonLocalGo(Binding binding, + LispObject tag) + throws ConditionThrowable + { + if (binding.env.inactive) + return error(new ControlError("Unmatched tag " + + binding.symbol.writeToString() + + " for GO outside of lexical extent.")); + + throw new Go(binding.env, binding.symbol); + } + + /** Throws a Return exception to cause a non-local transfer + * of control event, after checking that the extent of + * the catching block hasn't ended yet. + * + * This version is used by the compiler. + */ + public static final LispObject nonLocalReturn(LispObject blockId, + LispObject blockName, + LispObject result) + throws ConditionThrowable + { + if (blockId == null) + return error(new ControlError("Unmatched block " + + blockName.writeToString() + " for " + + "RETURN-FROM outside lexical extent.")); + + throw new Return(blockId, result); + } + + /** Throws a Return exception to cause a non-local transfer + * of control event, after checking that the extent of + * the catching block hasn't ended yet. + * + * This version is used by the interpreter. + */ + public static final LispObject nonLocalReturn(Binding binding, + Symbol block, + LispObject result) + throws ConditionThrowable + { + if (binding == null) + { + return error(new LispError("No block named " + block.getName() + + " is currently visible.")); + } + + if (binding.env.inactive) + return error(new ControlError("Unmatched block " + + binding.symbol.writeToString() + + " for RETURN-FROM outside of" + + " lexical extent.")); + + throw new Return(binding.symbol, binding.value, result); + } + public static final LispObject processTagBody(LispObject body, LispObject localTags, Environment env) @@ -676,7 +757,7 @@ continue; } } - throw new Go(binding.tagbody, tag); + throw new Go(binding.env, tag); } eval(current, env, thread); } Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun Oct 4 08:37:29 2009 @@ -3496,7 +3496,12 @@ throws ConditionThrowable { Environment ext = new Environment(env); - return processTagBody(args, preprocessTagBody(args, ext), ext); + try { + return processTagBody(args, preprocessTagBody(args, ext), ext); + } + finally { + ext.inactive = true; + } } }; @@ -3515,7 +3520,8 @@ return error(new ControlError("No tag named " + args.car().writeToString() + " is currently visible.")); - throw new Go(binding.tagbody, args.car()); + + return nonLocalGo(binding, args.car()); } }; @@ -3549,6 +3555,10 @@ } throw ret; } + finally + { + ext.inactive = true; + } } }; @@ -3566,20 +3576,10 @@ Symbol symbol; symbol = checkSymbol(args.car()); - LispObject block = env.lookupBlock(symbol); - if (block == null) - { - FastStringBuffer sb = new FastStringBuffer("No block named "); - sb.append(symbol.getName()); - sb.append(" is currently visible."); - error(new LispError(sb.toString())); - } - LispObject result; - if (length == 2) - result = eval(args.cadr(), env, LispThread.currentThread()); - else - result = NIL; - throw new Return(symbol, block, result); + return nonLocalReturn(env.getBlockBinding(symbol), symbol, + (length == 2) ? eval(args.cadr(), env, + LispThread.currentThread()) + : NIL); } }; 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 Sun Oct 4 08:37:29 2009 @@ -4506,6 +4506,7 @@ (when (tagbody-non-local-go-p block) ; We need a handler to catch non-local GOs. (let* ((HANDLER (gensym)) + (EXTENT-EXIT-HANDLER (gensym)) (*register* *register*) (go-register (allocate-register)) (tag-register (allocate-register))) @@ -4532,31 +4533,45 @@ (declare-object (tag-label tag))) +lisp-object+) (emit 'if_acmpne NEXT) ;; Jump if not EQ. - ;; Restore dynamic environment. (emit 'goto (tag-label tag)) (label NEXT))) ;; Not found. Re-throw Go. (label RETHROW) (aload go-register) + (emit 'aconst_null) ;; load null value + (emit-move-to-variable (tagbody-id-variable block)) + (emit 'athrow) + (label EXTENT-EXIT-HANDLER) + (emit 'aconst_null) ;; load null value + (emit-move-to-variable (tagbody-id-variable block)) (emit 'athrow) ;; Finally... (push (make-handler :from BEGIN-BLOCK :to END-BLOCK :code HANDLER :catch-type (pool-class +lisp-go-class+)) + *handlers*) + (push (make-handler :from BEGIN-BLOCK + :to END-BLOCK + :code EXTENT-EXIT-HANDLER + :catch-type 0) *handlers*))) (label EXIT) + (when (tagbody-non-local-go-p block) + (emit 'aconst_null) ;; load null value + (emit-move-to-variable (tagbody-id-variable block))) (when must-clear-values (emit-clear-values)) ;; TAGBODY returns NIL. (when target (emit-push-nil) - (emit-move-from-stack target)))) + (emit-move-from-stack target))) + ) (defknown p2-go (t t t) t) (defun p2-go (form target representation) ;; FIXME What if we're called with a non-NIL representation? - (declare (ignore representation)) + (declare (ignore target representation)) (let* ((name (cadr form)) (tag (find-tag name)) (tag-block (when tag (tag-block tag)))) @@ -4574,17 +4589,17 @@ (emit 'goto (tag-label tag)) (return-from p2-go)) ;; Non-local GO. - (emit 'new +lisp-go-class+) - (emit 'dup) - (emit-push-variable (tagbody-id-variable (tag-block tag))) - (compile-form `',(tag-label tag) 'stack nil) ; Tag. - (emit-invokespecial-init +lisp-go-class+ (lisp-object-arg-types 2)) - (emit 'athrow) + (emit-push-variable (tagbody-id-variable tag-block)) + (emit 'getstatic *this-class* + (if *file-compilation* + (declare-object-as-string (tag-label tag)) + (declare-object (tag-label tag))) + +lisp-object+) ; Tag. + (emit-invokestatic +lisp-class+ "nonLocalGo" (lisp-object-arg-types 2) + +lisp-object+) ;; Following code will not be reached, but is needed for JVM stack ;; consistency. - (when target - (emit-push-nil) - (emit-move-from-stack target)))) + (emit 'areturn))) (defknown p2-atom (t t t) t) (define-inlined-function p2-atom (form target representation) @@ -4691,6 +4706,7 @@ ;; We need a handler to catch non-local RETURNs. (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one (let ((HANDLER (gensym)) + (EXTENT-EXIT-HANDLER (gensym)) (THIS-BLOCK (gensym))) (label HANDLER) ;; The Return object is on the runtime stack. Stack depth is 1. @@ -4699,7 +4715,10 @@ (emit-push-variable (block-id-variable block)) ;; If it's not the block we're looking for... (emit 'if_acmpeq THIS-BLOCK) ; Stack depth is 1. + (label EXTENT-EXIT-HANDLER) ;; Not the tag we're looking for. + (emit 'aconst_null) ;; load null value + (emit-move-to-variable (block-id-variable block)) (emit 'athrow) (label THIS-BLOCK) (emit 'getfield +lisp-return-class+ "result" +lisp-object+) @@ -4709,14 +4728,22 @@ :to END-BLOCK :code HANDLER :catch-type (pool-class +lisp-return-class+)) + *handlers*) + (push (make-handler :from BEGIN-BLOCK + :to END-BLOCK + :code EXTENT-EXIT-HANDLER + :catch-type 0) *handlers*))) (label BLOCK-EXIT) + (when (block-id-variable block) + (emit 'aconst_null) ;; load null value + (emit-move-to-variable (block-id-variable block))) (fix-boxing representation nil))) (defknown p2-return-from (t t t) t) (defun p2-return-from (form target representation) ;; FIXME What if we're called with a non-NIL representation? - (declare (ignore representation)) + (declare (ignore target representation)) (let* ((name (second form)) (result-form (third form)) (block (find-block name))) @@ -4739,28 +4766,19 @@ (return-from p2-return-from)))) ;; Non-local RETURN. (aver (block-non-local-return-p block)) - (cond ((node-constant-p result-form) - (emit 'new +lisp-return-class+) - (emit 'dup) - (emit-push-variable (block-id-variable block)) - (emit-clear-values) - (compile-form result-form 'stack nil)) ; Result. - (t - (let* ((*register* *register*) - (temp-register (allocate-register))) - (emit-clear-values) - (compile-form result-form temp-register nil) ; Result. - (emit 'new +lisp-return-class+) - (emit 'dup) - (emit-push-variable (block-id-variable block)) - (aload temp-register)))) - (emit-invokespecial-init +lisp-return-class+ (lisp-object-arg-types 2)) - (emit 'athrow) + (emit-push-variable (block-id-variable block)) + (emit 'getstatic *this-class* + (if *file-compilation* + (declare-object-as-string (block-name block)) + (declare-object (block-name block))) + +lisp-object+) + (emit-clear-values) + (compile-form result-form 'stack nil) + (emit-invokestatic +lisp-class+ "nonLocalReturn" (lisp-object-arg-types 3) + +lisp-object+) ;; Following code will not be reached, but is needed for JVM stack ;; consistency. - (when target - (emit-push-nil) - (emit-move-from-stack target)))) + (emit 'areturn))) (defun emit-car/cdr (arg target representation field) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) Modified: trunk/abcl/src/org/armedbear/lisp/dolist.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/dolist.java (original) +++ trunk/abcl/src/org/armedbear/lisp/dolist.java Sun Oct 4 08:37:29 2009 @@ -58,9 +58,9 @@ bodyForm = bodyAndDecls.car(); LispObject blockId = new LispObject(); + final Environment ext = new Environment(env); try { - final Environment ext = new Environment(env); // Implicit block. ext.addBlock(NIL, blockId); // Evaluate the list form. @@ -122,6 +122,7 @@ finally { thread.lastSpecialBinding = lastSpecialBinding; + ext.inactive = true; } } Modified: trunk/abcl/src/org/armedbear/lisp/dotimes.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/dotimes.java (original) +++ trunk/abcl/src/org/armedbear/lisp/dotimes.java Sun Oct 4 08:37:29 2009 @@ -57,9 +57,9 @@ bodyForm = bodyAndDecls.car(); LispObject blockId = new LispObject(); + final Environment ext = new Environment(env); try { - Environment ext = new Environment(env); ext.addBlock(NIL, blockId); LispObject limit = eval(countForm, ext, thread); @@ -148,6 +148,7 @@ finally { thread.lastSpecialBinding = lastSpecialBinding; + ext.inactive = true; } } From ehuelsmann at common-lisp.net Sun Oct 4 13:30:52 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Oct 2009 09:30:52 -0400 Subject: [armedbear-cvs] r12171 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 4 09:30:50 2009 New Revision: 12171 Log: Cleanup thinko in addTagBinding: there's no need to specify the environment to add to. Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Environment.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Environment.java Sun Oct 4 09:30:50 2009 @@ -195,9 +195,9 @@ return null; } - public void addTagBinding(LispObject tag, Environment env, LispObject code) + public void addTagBinding(LispObject tag, LispObject code) { - tags = new Binding(tag, env, code, tags); + tags = new Binding(tag, this, code, tags); } public Binding getTagBinding(LispObject tag) Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Oct 4 09:30:50 2009 @@ -638,7 +638,7 @@ if (current instanceof Cons) continue; // It's a tag. - env.addTagBinding(current, env, body); + env.addTagBinding(current, body); localTags = new Cons(current, localTags); } return localTags; From ehuelsmann at common-lisp.net Sun Oct 4 14:01:59 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Oct 2009 10:01:59 -0400 Subject: [armedbear-cvs] r12172 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 4 10:01:58 2009 New Revision: 12172 Log: Fix dispatch() generic case. Fixes compiled MULTIPLE-VALUE-CALL with more than 8 arguments. Pointed out by piso. Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sun Oct 4 10:01:58 2009 @@ -761,7 +761,7 @@ return execute(args[0], args[1], args[2], args[3], args[4], args[5], args[6], args[7]); default: - return type_error(this, Symbol.FUNCTION); + return execute(args); } } From ehuelsmann at common-lisp.net Sun Oct 4 17:44:09 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Oct 2009 13:44:09 -0400 Subject: [armedbear-cvs] r12173 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 4 13:44:06 2009 New Revision: 12173 Log: Fix incorrect block name created for SETF functions in LABELS. The block used to be named (SETF FOO) instead of FOO; the former being illegal because BLOCK takes a SYMBOL identifier. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp 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 Sun Oct 4 13:44:06 2009 @@ -673,11 +673,12 @@ ((let* ((variable (make-variable :name (gensym))) (local-function (make-local-function :name name :compiland compiland - :variable variable))) + :variable variable)) + (block-name (fdefinition-block-name name))) (multiple-value-bind (body decls) (parse-body body) (setf (compiland-lambda-expression compiland) (rewrite-lambda - `(lambda ,lambda-list , at decls (block ,name , at body))))) + `(lambda ,lambda-list , at decls (block ,block-name , at body))))) (push variable *all-variables*) (push local-function local-functions))) ((dolist (local-function local-functions) From ehuelsmann at common-lisp.net Sun Oct 4 20:18:17 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Oct 2009 16:18:17 -0400 Subject: [armedbear-cvs] r12174 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 4 16:18:15 2009 New Revision: 12174 Log: Rewrite RETURN-FROM to fix MISC.293A, MISC.293B and MISC.293C. Add documentation as to why this type of rewriting is necessary. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp 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 Sun Oct 4 16:18:15 2009 @@ -362,6 +362,9 @@ (defknown p1-return-from (t) t) (defun p1-return-from (form) + (let ((new-form (rewrite-return-from form))) + (when (neq form new-form) + (return-from p1-return-from (p1 new-form)))) (let* ((name (second form)) (block (find-block name))) (when (null block) @@ -889,6 +892,16 @@ (defknown unsafe-p (t) t) (defun unsafe-p (args) + "Determines whether the args can cause 'stack unsafe situations'. +Returns T if this is the case. + +When a 'stack unsafe situation' is encountered, the stack cannot +be used for temporary storage of intermediary results. This happens +because one of the forms in ARGS causes a local transfer of control +- local GO instruction - which assumes an empty stack, or if one of +the args causes a Java exception handler to be installed, which +- when triggered - clears out the stack. +" (cond ((node-p args) (unsafe-p (node-form args))) ((atom args) @@ -906,6 +919,20 @@ (when (unsafe-p arg) (return t)))))))) +(defknown rewrite-return-from (t) t) +(defun rewrite-return-from (form) + (let* ((args (cdr form)) + (result-form (second args)) + (var (gensym))) + (if (unsafe-p (cdr args)) + (if (single-valued-p result-form) + `(let ((,var ,result-form)) + (return-from ,(first args) ,var)) + `(let ((,var (multiple-value-list ,result-form))) + (return-from ,(first args) (values-list ,var)))) + form))) + + (defknown rewrite-throw (t) t) (defun rewrite-throw (form) (let ((args (cdr form))) From ehuelsmann at common-lisp.net Sun Oct 4 20:30:58 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 04 Oct 2009 16:30:58 -0400 Subject: [armedbear-cvs] r12175 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 4 16:30:57 2009 New Revision: 12175 Log: Make non-local GO processing a tad more efficient, resulting in smaller byte code. 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 Sun Oct 4 16:30:57 2009 @@ -4525,18 +4525,16 @@ ;; to which there is no non-local GO instruction (dolist (tag (remove-if-not #'tag-used-non-locally (tagbody-tags block))) - (let ((NEXT (gensym))) - (aload tag-register) - (emit 'getstatic *this-class* - (if *file-compilation* - (declare-object-as-string (tag-label tag)) - (declare-object (tag-label tag))) - +lisp-object+) - (emit 'if_acmpne NEXT) ;; Jump if not EQ. - (emit 'goto (tag-label tag)) - (label NEXT))) - ;; Not found. Re-throw Go. + (aload tag-register) + (emit 'getstatic *this-class* + (if *file-compilation* + (declare-object-as-string (tag-label tag)) + (declare-object (tag-label tag))) + +lisp-object+) + ;; Jump if EQ. + (emit 'if_acmpeq (tag-label tag))) (label RETHROW) + ;; Not found. Re-throw Go. (aload go-register) (emit 'aconst_null) ;; load null value (emit-move-to-variable (tagbody-id-variable block)) From ehuelsmann at common-lisp.net Mon Oct 5 20:19:16 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 05 Oct 2009 16:19:16 -0400 Subject: [armedbear-cvs] r12176 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Oct 5 16:19:12 2009 New Revision: 12176 Log: Add OpenJDK identification of Darwin to the *FEATURES* setup and the OS type detection. Found by: John Pallister < john synchromesh com > Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Utilities.java 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 Oct 5 16:19:12 2009 @@ -2318,7 +2318,8 @@ Keyword.SUNOS, Keyword.CDR6)); } - else if (osName.startsWith("Mac OS X")) + else if (osName.startsWith("Mac OS X") || + osName.startsWith("Darwin")) { Symbol.FEATURES.setSymbolValue(list(Keyword.ARMEDBEAR, Keyword.ABCL, Modified: trunk/abcl/src/org/armedbear/lisp/Utilities.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Utilities.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Utilities.java Mon Oct 5 16:19:12 2009 @@ -50,7 +50,8 @@ static { String osName = System.getProperty("os.name"); isPlatformUnix = osName.startsWith("Linux") || - osName.startsWith("Mac OS X") || osName.startsWith("Solaris") || + osName.startsWith("Mac OS X") || osName.startsWith("Darwin") || + osName.startsWith("Solaris") || osName.startsWith("SunOS") || osName.startsWith("AIX") || osName.startsWith("FreeBSD") || osName.startsWith("OpenBSD") || osName.startsWith("NetBSD"); From mevenson at common-lisp.net Tue Oct 6 08:56:15 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 06 Oct 2009 04:56:15 -0400 Subject: [armedbear-cvs] r12177 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Oct 6 04:56:12 2009 New Revision: 12177 Log: Revert r12153 behavior to rethrow org.armedbear.lisp.Go out of INTERACTIVE-EVAL. Due to Erik's recent work [r12170] there should never be a Go thrown by non-local transfers of control, so this is no longer necessary. Additionally this code was causing an incorrect additional error in the top-level that was uncessary and confusing. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java 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 Tue Oct 6 04:56:12 2009 @@ -277,7 +277,7 @@ } catch (Go go) { - return error(go.getCondition()); + throw go; } catch (Throw t) { From vvoutilainen at common-lisp.net Tue Oct 6 20:42:05 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 06 Oct 2009 16:42:05 -0400 Subject: [armedbear-cvs] r12178 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Tue Oct 6 16:42:02 2009 New Revision: 12178 Log: check-initargs must consider methods for initialize-instance. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Oct 6 16:42:02 2009 @@ -1976,10 +1976,18 @@ (error 'program-error :format-control "Odd number of keyword arguments.")) (unless (getf initargs :allow-other-keys) - (let ((methods (compute-applicable-methods #'shared-initialize - (if initargs - `(,instance ,shared-initialize-param , at initargs) - (list instance shared-initialize-param)))) + (let ((methods + (nconc + (compute-applicable-methods + #'shared-initialize + (if initargs + `(,instance ,shared-initialize-param , at initargs) + (list instance shared-initialize-param))) + (compute-applicable-methods + #'initialize-instance + (if initargs + `(,instance , at initargs) + (list instance))))) (slots (%class-slots (class-of instance)))) (do* ((tail initargs (cddr tail)) (initarg (car tail) (car tail))) From vvoutilainen at common-lisp.net Wed Oct 7 16:25:10 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Wed, 07 Oct 2009 12:25:10 -0400 Subject: [armedbear-cvs] r12179 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Wed Oct 7 12:25:07 2009 New Revision: 12179 Log: Fix the initarg check for parameters that have a default value. 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 Wed Oct 7 12:25:07 2009 @@ -2005,9 +2005,11 @@ (let ((valid-initargs (method-lambda-list method))) (when (find (symbol-value initarg) valid-initargs :test #'(lambda (a b) - (or - (string= a b) - (string= b "&ALLOW-OTHER-KEYS")))) + (if (listp b) + (string= a (car b)) + (or + (string= a b) + (string= b "&ALLOW-OTHER-KEYS"))))) (return t)))))) From astalla at common-lisp.net Wed Oct 7 21:51:03 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 07 Oct 2009 17:51:03 -0400 Subject: [armedbear-cvs] r12180 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Oct 7 17:51:00 2009 New Revision: 12180 Log: Ticket #56: eliminated use of temporary files for COMPILE Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Wed Oct 7 17:51:00 2009 @@ -207,7 +207,7 @@ // ### load-compiled-function private static final Primitive LOAD_COMPILED_FUNCTION = - new Primitive("load-compiled-function", PACKAGE_SYS, true, "pathname") + new Primitive("load-compiled-function", PACKAGE_SYS, true, "source") { @Override public LispObject execute(LispObject arg) throws ConditionThrowable @@ -219,6 +219,14 @@ namestring = arg.getStringValue(); if (namestring != null) return loadCompiledFunction(namestring); + if(arg instanceof JavaObject) { + try { + return loadCompiledFunction((byte[]) arg.javaInstance(byte[].class)); + } catch(Throwable t) { + Debug.trace(t); + return error(new LispError("Unable to load " + arg.writeToString())); + } + } return error(new LispError("Unable to load " + arg.writeToString())); } }; Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java Wed Oct 7 17:51:00 2009 @@ -37,17 +37,7 @@ import java.util.HashSet; import java.util.Set; -public class JavaClassLoader extends ClassLoader -{ - private static final boolean isSableVM; - - static { - String vm = System.getProperty("java.vm.name"); - if (vm != null && vm.equals("SableVM")) - isSableVM = true; - else - isSableVM = false; - } +public class JavaClassLoader extends ClassLoader { private static JavaClassLoader persistentInstance; @@ -79,6 +69,10 @@ } } + public Class loadClassFromByteArray(byte[] classbytes) { + return loadClassFromByteArray(null, classbytes); + } + public Class loadClassFromByteArray(String className, byte[] classbytes) { 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 Oct 7 17:51:00 2009 @@ -1376,6 +1376,16 @@ new Pathname(namestring))); } + public static final LispObject makeCompiledFunctionFromClass(Class c) + throws Exception { + if (c != null) { + LispObject obj = (LispObject)c.newInstance(); + return obj; + } else { + return null; + } + } + private static final LispObject loadCompiledFunction(InputStream in, int size) { try @@ -1405,21 +1415,19 @@ } public static final LispObject loadCompiledFunction(byte[] bytes) throws Throwable { - Class c = (new JavaClassLoader()) - .loadClassFromByteArray(null, bytes, 0, bytes.length); - if (c != null) { - Constructor constructor = c.getConstructor((Class[])null); - LispObject obj = (LispObject)constructor - .newInstance((Object[])null); - if (obj instanceof Function) { - ((Function)obj).setClassBytes(bytes); - } - return obj; - } else { - return null; - } + return loadCompiledFunction(bytes, new JavaClassLoader()); } + public static final LispObject loadCompiledFunction(byte[] bytes, JavaClassLoader cl) throws Throwable { + Class c = cl.loadClassFromByteArray(null, bytes, 0, bytes.length); + LispObject obj = makeCompiledFunctionFromClass(c); + if (obj instanceof Function) { + ((Function)obj).setClassBytes(bytes); + } + return obj; + } + + public static final LispObject makeCompiledClosure(LispObject template, ClosureBinding[] context) throws ConditionThrowable 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 Oct 7 17:51:00 2009 @@ -119,6 +119,14 @@ { } + public Stream(Reader r) { + initAsCharacterInputStream(r); + } + + public Stream(Writer w) { + initAsCharacterOutputStream(w); + } + public Stream(InputStream inputStream, LispObject elementType) { this(inputStream, elementType, keywordDefault); 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 Oct 7 17:51:00 2009 @@ -146,11 +146,17 @@ (parse-body body) (let* ((expr `(lambda ,lambda-list , at decls (block ,block-name , at body))) - (classfile-name (next-classfile-name)) - (classfile (report-error - (jvm:compile-defun name expr nil - classfile-name))) + (classfile (next-classfile-name)) + (result (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (report-error + (jvm:compile-defun name expr nil + classfile f)))) (compiled-function (verify-load classfile))) + (declare (ignore result)) (cond (compiled-function (setf form @@ -205,10 +211,14 @@ (let ((name (second form))) (eval form) (let* ((expr (function-lambda-expression (macro-function name))) - (classfile-name (next-classfile-name)) - (classfile - (ignore-errors - (jvm:compile-defun nil expr nil classfile-name)))) + (classfile (next-classfile-name))) + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (ignore-errors + (jvm:compile-defun nil expr nil classfile f))) (if (null (verify-load classfile)) ;; FIXME error or warning (format *error-output* "; Unable to compile macro ~A~%" name) @@ -342,10 +352,17 @@ (eq (%car function-form) 'FUNCTION)) (let ((lambda-expression (cadr function-form))) (jvm::with-saved-compiler-policy - (let* ((classfile-name (next-classfile-name)) - (classfile (report-error - (jvm:compile-defun nil lambda-expression nil classfile-name))) + (let* ((classfile (next-classfile-name)) + (result + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (report-error + (jvm:compile-defun nil lambda-expression nil classfile f)))) (compiled-function (verify-load classfile))) + (declare (ignore result)) (cond (compiled-function (setf (getf tail key) `(load-compiled-function ,(file-namestring classfile)))) @@ -356,9 +373,16 @@ (declaim (ftype (function (t) t) convert-toplevel-form)) (defun convert-toplevel-form (form) (let* ((expr `(lambda () ,form)) - (classfile-name (next-classfile-name)) - (classfile (report-error (jvm:compile-defun nil expr nil classfile-name))) + (classfile (next-classfile-name)) + (result + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (report-error (jvm:compile-defun nil expr nil classfile f)))) (compiled-function (verify-load classfile))) + (declare (ignore result)) (setf form (if compiled-function `(funcall (load-compiled-function ,(file-namestring classfile))) 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 Oct 7 17:51:00 2009 @@ -4921,16 +4921,16 @@ (emit-push-nil) (emit-move-from-stack target))) -(defun compile-and-write-to-file (class-file compiland) +(defun compile-and-write-to-stream (class-file compiland stream) (with-class-file class-file (let ((*current-compiland* compiland)) (with-saved-compiler-policy (p2-compiland compiland) - (write-class-file (compiland-class-file compiland)))))) + (write-class-file (compiland-class-file compiland) stream))))) -(defun set-compiland-and-write-class-file (class-file compiland) +(defun set-compiland-and-write-class (class-file compiland stream) (setf (compiland-class-file compiland) class-file) - (compile-and-write-to-file class-file compiland)) + (compile-and-write-to-stream class-file compiland stream)) (defmacro with-temp-class-file (pathname class-file lambda-list &body body) @@ -4949,15 +4949,18 @@ (let* ((pathname (funcall *pathnames-generator*)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) - (set-compiland-and-write-class-file class-file compiland) + (with-open-class-file (f class-file) + (set-compiland-and-write-class class-file compiland f)) (setf (local-function-class-file local-function) class-file))) (t - (with-temp-class-file - pathname class-file lambda-list - (set-compiland-and-write-class-file class-file compiland) + (let ((class-file (make-class-file + :pathname (funcall *pathnames-generator*) + :lambda-list lambda-list))) + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (set-compiland-and-write-class class-file compiland stream) (setf (local-function-class-file local-function) class-file) (setf (local-function-function local-function) - (load-compiled-function pathname))))))) + (load-compiled-function (sys::%get-output-stream-bytes stream))))))))) (defun emit-make-compiled-closure-for-labels (local-function compiland declaration) @@ -4981,19 +4984,24 @@ (let* ((pathname (funcall *pathnames-generator*)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) - (set-compiland-and-write-class-file class-file compiland) + (with-open-class-file (f class-file) + (set-compiland-and-write-class class-file compiland f)) (setf (local-function-class-file local-function) class-file) (let ((g (declare-local-function local-function))) (emit-make-compiled-closure-for-labels local-function compiland g)))) (t - (with-temp-class-file - pathname class-file lambda-list - (set-compiland-and-write-class-file class-file compiland) + (let ((class-file (make-class-file + :pathname (funcall *pathnames-generator*) + :lambda-list lambda-list))) + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (set-compiland-and-write-class class-file compiland stream) (setf (local-function-class-file local-function) class-file) - (let ((g (declare-object (load-compiled-function pathname)))) + (let ((g (declare-object + (load-compiled-function + (sys::%get-output-stream-bytes stream))))) (emit-make-compiled-closure-for-labels - local-function compiland g))))))) + local-function compiland g)))))))) (defknown p2-flet-node (t t t) t) (defun p2-flet-node (block target representation) @@ -5041,7 +5049,8 @@ (make-class-file :pathname (funcall *pathnames-generator*) :lambda-list lambda-list)) (let ((class-file (compiland-class-file compiland))) - (compile-and-write-to-file class-file compiland) + (with-open-class-file (f class-file) + (compile-and-write-to-stream class-file compiland f)) (emit 'getstatic *this-class* (declare-local-function (make-local-function :class-file class-file)) @@ -5051,14 +5060,13 @@ (setf (compiland-class-file compiland) (make-class-file :pathname pathname :lambda-list lambda-list)) - (unwind-protect - (progn - (compile-and-write-to-file (compiland-class-file compiland) - compiland) - (emit 'getstatic *this-class* - (declare-object (load-compiled-function pathname)) - +lisp-object+)) - (delete-file pathname))))) + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (compile-and-write-to-stream (compiland-class-file compiland) + compiland stream) + (emit 'getstatic *this-class* + (declare-object (load-compiled-function + (sys::%get-output-stream-bytes stream))) + +lisp-object+))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) (duplicate-closure-array *current-compiland*) @@ -8030,7 +8038,14 @@ (setf (compiland-arity compiland) arg-count) (get-descriptor (list +lisp-object-array+) +lisp-object+))))) -(defun write-class-file (class-file) +(defmacro with-open-class-file ((var class-file) &body body) + `(with-open-file (,var (class-file-pathname ,class-file) + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + , at body)) + +(defun write-class-file (class-file stream) (let* ((super (class-file-superclass class-file)) (this-index (pool-class (class-file-class class-file))) (super-index (pool-class super)) @@ -8045,43 +8060,39 @@ (when (and (boundp '*source-line-number*) (fixnump *source-line-number*)) (pool-name "LineNumberTable")) ; Must be in pool! - - ;; Write out the class file. - (with-open-file (stream (class-file-pathname class-file) - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (write-u4 #xCAFEBABE stream) - (write-u2 3 stream) - (write-u2 45 stream) - (write-constant-pool stream) - ;; access flags - (write-u2 #x21 stream) - (write-u2 this-index stream) - (write-u2 super-index stream) - ;; interfaces count - (write-u2 0 stream) - ;; fields count - (write-u2 (length *fields*) stream) - ;; fields - (dolist (field *fields*) - (write-field field stream)) - ;; methods count - (write-u2 (1+ (length (class-file-methods class-file))) stream) - ;; methods - (dolist (method (class-file-methods class-file)) - (write-method method stream)) - (write-method constructor stream) - ;; attributes count - (cond (*file-compilation* - ;; attributes count - (write-u2 1 stream) - ;; attributes table - (write-source-file-attr (file-namestring *compile-file-truename*) - stream)) - (t - ;; attributes count - (write-u2 0 stream)))))) + + (write-u4 #xCAFEBABE stream) + (write-u2 3 stream) + (write-u2 45 stream) + (write-constant-pool stream) + ;; access flags + (write-u2 #x21 stream) + (write-u2 this-index stream) + (write-u2 super-index stream) + ;; interfaces count + (write-u2 0 stream) + ;; fields count + (write-u2 (length *fields*) stream) + ;; fields + (dolist (field *fields*) + (write-field field stream)) + ;; methods count + (write-u2 (1+ (length (class-file-methods class-file))) stream) + ;; methods + (dolist (method (class-file-methods class-file)) + (write-method method stream)) + (write-method constructor stream) + ;; attributes count + (cond (*file-compilation* + ;; attributes count + (write-u2 1 stream) + ;; attributes table + (write-source-file-attr (file-namestring *compile-file-truename*) + stream)) + (t + ;; attributes count + (write-u2 0 stream))) + stream)) (defknown p2-compiland-process-type-declarations (list) t) (defun p2-compiland-process-type-declarations (body) @@ -8359,7 +8370,7 @@ (push execute-method (class-file-methods class-file))) t) -(defun compile-1 (compiland) +(defun compile-1 (compiland stream) (let ((*all-variables* nil) (*closure-variables* nil) (*undefined-variables* nil) @@ -8393,8 +8404,7 @@ ;; Pass 2. (with-class-file (compiland-class-file compiland) (p2-compiland compiland) - (write-class-file (compiland-class-file compiland))) - (class-file-pathname (compiland-class-file compiland))))) + (write-class-file (compiland-class-file compiland) stream))))) (defvar *compiler-error-bailout*) @@ -8402,7 +8412,7 @@ `(lambda ,(cadr form) (error 'program-error :format-control "Execution of a form compiled with errors."))) -(defun compile-defun (name form environment filespec) +(defun compile-defun (name form environment filespec stream) (aver (eq (car form) 'LAMBDA)) (catch 'compile-defun-abort (let* ((class-file (make-class-file :pathname filespec @@ -8415,13 +8425,15 @@ :class-file (make-class-file :pathname ,filespec :lambda-name ',name - :lambda-list (cadr ',form)))))) + :lambda-list (cadr ',form))) + ,stream))) (*compile-file-environment* environment)) (compile-1 (make-compiland :name name :lambda-expression (precompiler:precompile-form form t environment) - :class-file class-file))))) + :class-file class-file) + stream)))) (defvar *catch-errors* t) @@ -8517,11 +8529,22 @@ (tempfile (make-temp-file))) (with-compilation-unit () (with-saved-compiler-policy - (unwind-protect - (setf compiled-function - (load-compiled-function - (compile-defun name expr env tempfile)))) - (delete-file tempfile))) + (setf compiled-function + (load-compiled-function + (if *file-compilation* + (unwind-protect + (progn + (with-open-file (f tempfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (compile-defun name expr env tempfile f)) + tempfile) + (delete-file tempfile)) + (with-open-stream (s (sys::%make-byte-array-output-stream)) + (compile-defun name expr env tempfile s) + (finish-output s) + (sys::%get-output-stream-bytes s))))))) (when (and name (functionp compiled-function)) (sys::set-function-definition name compiled-function definition)) (or name compiled-function))) From ehuelsmann at common-lisp.net Fri Oct 9 20:38:28 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 09 Oct 2009 16:38:28 -0400 Subject: [armedbear-cvs] r12181 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 9 16:38:25 2009 New Revision: 12181 Log: Prevent nested compilation of CLOS generated methods. This prevents recursive compilation of the same method while it's already being compiled. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri Oct 9 16:38:25 2009 @@ -1449,6 +1449,7 @@ } }; + /** Stub to be replaced later when signal.lisp has been loaded. */ // ### error private static final Primitive ERROR = new Primitive(Symbol.ERROR, "datum &rest arguments") @@ -1470,6 +1471,18 @@ } }; + /** Stub replaced when compiler-pass2.lisp has been loaded */ + // ### autocompile + private static final Primitive AUTOCOMPILE = + new Primitive(Symbol.AUTOCOMPILE, "function") + { + @Override + public LispObject execute(LispObject function) throws ConditionThrowable + { + return NIL; + } + }; + // ### signal private static final Primitive SIGNAL = new Primitive(Symbol.SIGNAL, "datum &rest arguments") 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 Oct 9 16:38:25 2009 @@ -2943,6 +2943,10 @@ PACKAGE_JAVA.addExternalSymbol("JMETHOD-RETURN-TYPE"); // External symbols in SYSTEM package. + public static final Symbol _ENABLE_AUTOCOMPILE_ = + PACKAGE_SYS.addExternalSymbol("*ENABLE-AUTOCOMPILE*"); + public static final Symbol AUTOCOMPILE = + PACKAGE_SYS.addExternalSymbol("AUTOCOMPILE"); public static final Symbol ENVIRONMENT = PACKAGE_SYS.addExternalSymbol("ENVIRONMENT"); public static final Symbol FORWARD_REFERENCED_CLASS = 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 Oct 9 16:38:25 2009 @@ -1335,9 +1335,9 @@ (slow-method-lookup ,gf args)))))) nil)))))) - (when (and (fboundp 'compile) + (when (and (fboundp 'autocompile) (not (autoloadp 'compile))) - (setf code (or (compile nil code) code))) + (setf code (or (autocompile code) code))) code)) @@ -1535,7 +1535,7 @@ (lambda (primary) `(funcall ,(%method-function primary) args nil)) primaries))))))))) - (or (ignore-errors (compile nil emf-form)) + (or (ignore-errors (autocompile emf-form)) (coerce-to-function emf-form)))) (defun generate-emf-lambda (method-function next-emfun) @@ -1753,10 +1753,10 @@ :specializers (list class) :function (if (autoloadp 'compile) method-function - (compile nil method-function)) + (autocompile method-function)) :fast-function (if (autoloadp 'compile) fast-function - (compile nil fast-function)) + (autocompile fast-function)) :slot-name slot-name))) (%add-method gf method) method)))) @@ -1778,10 +1778,10 @@ ;; :function `(function ,method-function) :function (if (autoloadp 'compile) method-function - (compile nil method-function)) + (autocompile method-function)) :fast-function (if (autoloadp 'compile) fast-function - (compile nil fast-function)) + (autocompile fast-function)) ))) (fmakunbound 'class-name) 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 Fri Oct 9 16:38:25 2009 @@ -8758,4 +8758,11 @@ (initialize-p2-handlers) +(defun sys:autocompile (function) + (when sys:*enable-autocompile* + (let ((sys:*enable-autocompile* nil)) + (values (compile nil function))))) + +(setf sys:*enable-autocompile* t) + (provide "COMPILER-PASS2") From ehuelsmann at common-lisp.net Fri Oct 9 21:20:16 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 09 Oct 2009 17:20:16 -0400 Subject: [armedbear-cvs] r12182 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 9 17:20:14 2009 New Revision: 12182 Log: Fix compile warning introduced by the 'autocompile' commit. 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 Fri Oct 9 17:20:14 2009 @@ -8758,6 +8758,8 @@ (initialize-p2-handlers) +(defvar sys:*enable-autocompile*) + (defun sys:autocompile (function) (when sys:*enable-autocompile* (let ((sys:*enable-autocompile* nil)) From ehuelsmann at common-lisp.net Fri Oct 9 21:31:51 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 09 Oct 2009 17:31:51 -0400 Subject: [armedbear-cvs] r12183 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 9 17:31:50 2009 New Revision: 12183 Log: Fix last Gray stream incompatibilities: generic functions overlapping with CL functions are no longer have the STREAM- prefix. Note: this commit also removes gray stream testing code which does not belong in the "production" image of our software. Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Fri Oct 9 17:31:50 2009 @@ -94,25 +94,7 @@ ;;;; ;;;; Notes ;;;; ===== -;;;; CLOSE is not a generic function in this implementation. Instead, -;;;; the generic is called STREAM-CLOSE and the function CLOSE calls -;;;; STREAM-CLOSE. The same goes for STREAMP, INPUT-STREAM-P, -;;;; OUTPUT-STREAM-P and STREAM-ELEMENT-TYPE. The generic functions for -;;;; these are STREAM-STREAMP, STREAM-INPUT-STREAM-P, -;;;; STREAM-OUTPUT-STREAM-P and STREAM-STREAM-ELEMENT-TYPE. ;;;; -;;;; The standard Corman Lisp streams are not derived from -;;;; FUNDAMENTAL-STREAM. All the stream functions check to see if the -;;;; stream is an original Corman Lisp stream and forward on to the -;;;; original function implementations. -;;;; -;;;; The string streams are implemented in this file as Gray streams -;;;; but do not replace the Corman Lisp string streams. They are only -;;;; implemented here to test the Gray stream functionality. These methods -;;;; are called: -;;;; GRAY-MAKE-STRING-OUTPUT-STREAM -;;;; GRAY-GET-OUTPUT-STREAM-STRING -;;;; GRAY-MAKE-STRING-INPUT-STREAM ;;;; ;;;; Much of the implementation of the Gray streams below is from the ;;;; document referenced earlier. @@ -123,7 +105,6 @@ (:nicknames "GS") ;; # fb 1.01 (:export "FUNDAMENTAL-STREAM" - "STREAM-CLOSE" "STREAM-OPEN-STREAM-P" "STREAM-STREAMP" "STREAM-INPUT-STREAM-P" @@ -200,21 +181,14 @@ (defclass fundamental-stream ()) -(defgeneric stream-close (stream &key abort)) -(defgeneric stream-open-stream-p (stream)) -(defgeneric stream-streamp (stream)) -(defgeneric stream-input-stream-p (stream)) -(defgeneric stream-input-character-stream-p (stream)) ;; # fb 1.01 -(defgeneric stream-output-stream-p (stream)) -(defgeneric stream-stream-element-type (stream)) +(defgeneric gray-close (stream &key abort)) +(defgeneric gray-open-stream-p (stream)) +(defgeneric gray-streamp (stream)) +(defgeneric gray-input-stream-p (stream)) +(defgeneric gray-input-character-stream-p (stream)) ;; # fb 1.01 +(defgeneric gray-output-stream-p (stream)) +(defgeneric gray-stream-element-type (stream)) -(defmethod stream-close (stream &key abort) - (declare (ignore stream abort)) - nil) - -(defmethod stream-streamp (s) - (declare (ignore s)) - nil) (defmethod stream-streamp ((s fundamental-stream)) s) @@ -225,20 +199,12 @@ (and (stream-input-stream-p s) (eq (stream-stream-element-type s) 'character))) -(defmethod stream-input-stream-p (s) - (declare (ignore s)) - nil) - (defmethod stream-input-stream-p ((s fundamental-input-stream)) (declare (ignore s)) t) (defclass fundamental-output-stream (fundamental-stream)) -(defmethod stream-output-stream-p (s) - (declare (ignore s)) - nil) - (defmethod stream-output-stream-p ((s fundamental-output-stream)) (declare (ignore s)) t) @@ -539,72 +505,6 @@ (funcall *old-write-byte* integer binary-output-stream) (stream-write-byte binary-output-stream integer))) -(defclass string-input-stream (fundamental-character-input-stream) - ((string :initarg :string :type string) - (index :initarg :start :type fixnum) - (end :initarg :end :type fixnum))) - -(defun gray-make-string-input-stream (string &optional (start 0) end) - (make-instance 'string-input-stream :string string - :start start :end (or end (length string)))) - -(defmethod stream-read-char ((stream string-input-stream)) - (with-slots (index end string) stream - (if (>= index end) - :eof - (prog1 - (char string index) - (incf index))))) - -(defmethod stream-unread-char ((stream string-input-stream) character) - (with-slots (index end string) stream - (decf index) - (assert (eql (char string index) character)) - nil)) - -(defmethod stream-read-line ((stream string-input-stream)) - (with-slots (index end string) stream - (let* ((endline (position #\newline string :start index :end end)) - (line (subseq string index endline))) - (if endline - (progn - (setq index (1+ endline)) - (values line nil)) - (progn - (setq index end) - (values line t)))))) - -(defclass string-output-stream (fundamental-character-output-stream) - ((string :initform nil :initarg :string))) - -(defun gray-make-string-output-stream () - (make-instance 'string-output-stream)) - -(defun gray-get-output-stream-string (stream) - (with-slots (string) stream - (if (null string) - "" - (prog1 - (coerce string 'string) - (setq string nil))))) - -(defmethod stream-write-char ((stream string-output-stream) character) - (with-slots (string) stream - (when (null string) - (setq string (make-array 64 :slement-type 'character - :fill-pointer 0 :adjustable t))) - (vector-push-extend character string) - character)) - -(defmethod stream-line-column ((stream string-output-stream)) - (with-slots (string) stream - (if (null string) - 0 - (let ((nx (position #\newline string :from-end t))) - (if (null nx) - (length string) - (- (length string) nx 1)))))) - (defmethod stream-line-column ((stream stream)) nil) @@ -614,40 +514,26 @@ nil ;(funcall *old-stream-column* stream) (stream-line-column stream)))) -(defun gray-stream-element-type (stream) - (if (old-streamp stream) - (funcall *old-stream-element-type* stream) - (stream-stream-element-type stream))) +(defmethod gray-stream-element-type (stream) + (funcall *old-stream-element-type* stream)) -(defun gray-close (stream &key abort) - (if (old-streamp stream) - (funcall *old-close* stream :abort abort) - (stream-close stream :abort nil))) +(defmethod gray-close (stream &key abort) + (funcall *old-close* stream :abort abort)) -(defun gray-input-stream-p (stream) - (if (old-streamp stream) - (funcall *old-input-stream-p* stream) - (stream-input-stream-p stream))) +(defmethod gray-input-stream-p (stream) + (funcall *old-input-stream-p* stream)) -(defun gray-input-character-stream-p (stream) - (if (old-streamp stream) - (funcall *old-input-character-stream-p* stream) - (stream-input-character-stream-p stream))) +(defmethod gray-input-character-stream-p (stream) + (funcall *old-input-character-stream-p* stream)) -(defun gray-output-stream-p (stream) - (if (old-streamp stream) - (funcall *old-output-stream-p* stream) - (stream-output-stream-p stream))) +(defmethod gray-output-stream-p (stream) + (funcall *old-output-stream-p* stream)) -(defun gray-open-stream-p (stream) - (if (old-streamp stream) - (funcall *old-open-stream-p* stream) - (stream-open-stream-p stream))) +(defmethod gray-open-stream-p (stream) + (funcall *old-open-stream-p* stream)) -(defun gray-streamp (stream) - (if (old-streamp stream) - (funcall *old-streamp* stream) - (stream-streamp stream))) +(defmethod gray-streamp (stream) + (funcall *old-streamp* stream)) (defun gray-write-sequence (sequence stream &key (start 0) end) (if (old-streamp stream) @@ -659,24 +545,6 @@ (funcall *old-read-sequence* sequence stream :start start :end end) (stream-read-sequence stream sequence start end))) -(defstruct two-way-stream-g - input-stream output-stream) - -(defun gray-make-two-way-stream (in out) - (if (and (old-streamp in) (old-streamp out)) - (funcall *old-make-two-way-stream* in out) - (make-two-way-stream-g :input-stream in :output-stream out))) - -(defun gray-two-way-stream-input-stream (stream) - (if (old-streamp stream) - (funcall *old-two-way-stream-input-stream* stream) - (two-way-stream-g-input-stream stream))) - -(defun gray-two-way-stream-output-stream (stream) - (if (old-streamp stream) - (funcall *old-two-way-stream-output-stream* stream) - (two-way-stream-g-output-stream stream))) - (setf (symbol-function 'common-lisp::read-char) #'gray-read-char) (setf (symbol-function 'common-lisp::peek-char) #'gray-peek-char) (setf (symbol-function 'common-lisp::unread-char) #'gray-unread-char) @@ -703,8 +571,5 @@ (setf (symbol-function 'common-lisp::streamp) #'gray-streamp) (setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence) (setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence) -(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream) -(setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream) -(setf (symbol-function 'common-lisp::two-way-stream-output-stream) #'gray-two-way-stream-output-stream) (provide 'gray-streams) From ehuelsmann at common-lisp.net Sat Oct 10 12:15:23 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 10 Oct 2009 08:15:23 -0400 Subject: [armedbear-cvs] r12184 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 10 08:15:20 2009 New Revision: 12184 Log: Replace "cons + compile" with "use closure" where ever possible. This should mean a performance increase. 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 Sat Oct 10 08:15:20 2009 @@ -872,10 +872,8 @@ (setf (classes-to-emf-table gf) (make-hash-table :test #'equal)) (%init-eql-specializations gf (collect-eql-specializer-objects gf)) (set-funcallable-instance-function - gf - (make-closure `(lambda (&rest args) - (initial-discriminating-function ,gf args)) - nil)) + gf #'(lambda (&rest args) + (initial-discriminating-function gf args))) ;; FIXME Do we need to warn on redefinition somewhere else? (let ((*warn-on-redefinition* nil)) (setf (fdefinition (%generic-function-name gf)) gf)) @@ -1210,130 +1208,135 @@ (defun std-compute-discriminating-function (gf) (let ((code - (cond ((and (= (length (generic-function-methods gf)) 1) - (typep (car (generic-function-methods gf)) 'standard-reader-method)) -;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf)) - (make-closure - (let* ((method (%car (generic-function-methods gf))) - (class (car (%method-specializers method))) - (slot-name (reader-method-slot-name method))) - `(lambda (arg) - (declare (optimize speed)) - (let* ((layout (std-instance-layout arg)) - (location (get-cached-slot-location ,gf layout))) - (unless location - (unless (simple-typep arg ,class) - ;; FIXME no applicable method - (error 'simple-type-error - :datum arg - :expected-type ,class)) - (setf location (slow-reader-lookup ,gf layout ',slot-name))) - (if (consp location) - ;; Shared slot. - (cdr location) - (standard-instance-access arg location))))) - nil)) - (t - (let* ((emf-table (classes-to-emf-table gf)) - (number-required (length (gf-required-args gf))) - (lambda-list (%generic-function-lambda-list gf)) - (exact (null (intersection lambda-list - '(&rest &optional &key - &allow-other-keys &aux))))) - (make-closure - (cond ((= number-required 1) - (if exact - (cond ((and (eq (generic-function-method-combination gf) 'standard) - (= (length (generic-function-methods gf)) 1)) - (let* ((method (%car (generic-function-methods gf))) - (specializer (car (%method-specializers method))) - (function (or (%method-fast-function method) - (%method-function method)))) - (if (eql-specializer-p specializer) - (let ((specializer-object (eql-specializer-object specializer))) - `(lambda (arg) - (declare (optimize speed)) - (if (eql arg ',specializer-object) - (funcall ,function arg) - (no-applicable-method ,gf (list arg))))) - `(lambda (arg) - (declare (optimize speed)) - (unless (simple-typep arg ,specializer) - ;; FIXME no applicable method - (error 'simple-type-error - :datum arg - :expected-type ,specializer)) - (funcall ,function arg))))) - (t - `(lambda (arg) - (declare (optimize speed)) - (let* ((specialization (%get-arg-specialization ,gf arg)) - (emfun (or (gethash1 specialization ,emf-table) - (slow-method-lookup-1 ,gf arg specialization)))) - (if emfun - (funcall emfun (list arg)) - (apply #'no-applicable-method ,gf (list arg))))) - )) - `(lambda (&rest args) - (declare (optimize speed)) - (unless (>= (length args) 1) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name ,gf)))) - (let ((emfun (get-cached-emf ,gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup ,gf args)))))) - ((= number-required 2) - (if exact - `(lambda (arg1 arg2) - (declare (optimize speed)) - (let* ((args (list arg1 arg2)) - (emfun (get-cached-emf ,gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup ,gf args)))) - `(lambda (&rest args) - (declare (optimize speed)) - (unless (>= (length args) 2) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name ,gf)))) - (let ((emfun (get-cached-emf ,gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup ,gf args)))))) - ((= number-required 3) - (if exact - `(lambda (arg1 arg2 arg3) - (declare (optimize speed)) - (let* ((args (list arg1 arg2 arg3)) - (emfun (get-cached-emf ,gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup ,gf args)))) - `(lambda (&rest args) - (declare (optimize speed)) - (unless (>= (length args) 3) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name ,gf)))) - (let ((emfun (get-cached-emf ,gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup ,gf args)))))) - (t - `(lambda (&rest args) - (declare (optimize speed)) - (unless (,(if exact '= '>=) (length args) ,number-required) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name ,gf)))) - (let ((emfun (get-cached-emf ,gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup ,gf args)))))) - nil)))))) + (cond + ((and (= (length (generic-function-methods gf)) 1) + (typep (car (generic-function-methods gf)) 'standard-reader-method)) + ;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf)) + + (let* ((method (%car (generic-function-methods gf))) + (class (car (%method-specializers method))) + (slot-name (reader-method-slot-name method))) + #'(lambda (arg) + (declare (optimize speed)) + (let* ((layout (std-instance-layout arg)) + (location (get-cached-slot-location gf layout))) + (unless location + (unless (simple-typep arg class) + ;; FIXME no applicable method + (error 'simple-type-error + :datum arg + :expected-type class)) + (setf location (slow-reader-lookup gf layout slot-name))) + (if (consp location) + ;; Shared slot. + (cdr location) + (standard-instance-access arg location)))))) + + (t + (let* ((emf-table (classes-to-emf-table gf)) + (number-required (length (gf-required-args gf))) + (lambda-list (%generic-function-lambda-list gf)) + (exact (null (intersection lambda-list + '(&rest &optional &key + &allow-other-keys &aux))))) + (cond + ((= number-required 1) + (if exact + (cond + ((and (eq (generic-function-method-combination gf) 'standard) + (= (length (generic-function-methods gf)) 1)) + (let* ((method (%car (generic-function-methods gf))) + (specializer (car (%method-specializers method))) + (function (or (%method-fast-function method) + (%method-function method)))) + (if (eql-specializer-p specializer) + (let ((specializer-object (eql-specializer-object specializer))) + #'(lambda (arg) + (declare (optimize speed)) + (if (eql arg specializer-object) + (funcall function arg) + (no-applicable-method gf (list arg))))) + #'(lambda (arg) + (declare (optimize speed)) + (unless (simple-typep arg specializer) + ;; FIXME no applicable method + (error 'simple-type-error + :datum arg + :expected-type specializer)) + (funcall function arg))))) + (t + #'(lambda (arg) + (declare (optimize speed)) + (let* ((specialization + (%get-arg-specialization gf arg)) + (emfun (or (gethash1 specialization + emf-table) + (slow-method-lookup-1 + gf arg specialization)))) + (if emfun + (funcall emfun (list arg)) + (apply #'no-applicable-method gf (list arg))))) + )) + #'(lambda (&rest args) + (declare (optimize speed)) + (unless (>= (length args) 1) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name gf)))) + (let ((emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args)))))) + ((= number-required 2) + (if exact + #'(lambda (arg1 arg2) + (declare (optimize speed)) + (let* ((args (list arg1 arg2)) + (emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args)))) + #'(lambda (&rest args) + (declare (optimize speed)) + (unless (>= (length args) 2) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name gf)))) + (let ((emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args)))))) + ((= number-required 3) + (if exact + #'(lambda (arg1 arg2 arg3) + (declare (optimize speed)) + (let* ((args (list arg1 arg2 arg3)) + (emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args)))) + #'(lambda (&rest args) + (declare (optimize speed)) + (unless (>= (length args) 3) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name gf)))) + (let ((emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args)))))) + (t + (make-closure + `(lambda (&rest args) + (declare (optimize speed)) + (unless (,(if exact '= '>=) (length args) ,number-required) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name ,gf)))) + (let ((emfun (get-cached-emf ,gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup ,gf args)))) nil)))))))) (when (and (fboundp 'autocompile) (not (autoloadp 'compile))) @@ -1472,52 +1475,55 @@ (setf around (car arounds)) (when (null primaries) (error "No primary methods for the generic function ~S." gf)) - (cond (around - (let ((next-emfun - (funcall - (if (eq (class-of gf) (find-class 'standard-generic-function)) - #'std-compute-effective-method-function - #'compute-effective-method-function) - gf (remove around methods)))) - (setf emf-form -;; `(lambda (args) -;; (funcall ,(%method-function around) args ,next-emfun)) - (generate-emf-lambda (%method-function around) next-emfun) - ))) - ((eq mc-name 'standard) - (let* ((next-emfun (compute-primary-emfun (cdr primaries))) - (befores (remove-if-not #'before-method-p methods)) - (reverse-afters - (reverse (remove-if-not #'after-method-p methods)))) - (setf emf-form - (cond ((and (null befores) (null reverse-afters)) - (if (%method-fast-function (car primaries)) - (ecase (length (gf-required-args gf)) - (1 - `(lambda (args) - (declare (optimize speed)) - (funcall ,(%method-fast-function (car primaries)) (car args)))) - (2 - `(lambda (args) - (declare (optimize speed)) - (funcall ,(%method-fast-function (car primaries)) - (car args) - (cadr args))))) -;; `(lambda (args) -;; (declare (optimize speed)) -;; (funcall ,(%method-function (car primaries)) args ,next-emfun)) - (generate-emf-lambda (%method-function (car primaries)) - next-emfun) - )) - (t - `(lambda (args) - (declare (optimize speed)) - (dolist (before ',befores) - (funcall (%method-function before) args nil)) - (multiple-value-prog1 - (funcall (%method-function ,(car primaries)) args ,next-emfun) - (dolist (after ',reverse-afters) - (funcall (%method-function after) args nil))))))))) + (cond + (around + (let ((next-emfun + (funcall + (if (eq (class-of gf) (find-class 'standard-generic-function)) + #'std-compute-effective-method-function + #'compute-effective-method-function) + gf (remove around methods)))) + (setf emf-form +;;; `(lambda (args) +;;; (funcall ,(%method-function around) args ,next-emfun)) + (generate-emf-lambda (%method-function around) next-emfun) + ))) + ((eq mc-name 'standard) + (let* ((next-emfun (compute-primary-emfun (cdr primaries))) + (befores (remove-if-not #'before-method-p methods)) + (reverse-afters + (reverse (remove-if-not #'after-method-p methods)))) + (setf emf-form + (cond + ((and (null befores) (null reverse-afters)) + (let ((fast-function (%method-fast-function (car primaries)))) + + (if fast-function + (ecase (length (gf-required-args gf)) + (1 + #'(lambda (args) + (declare (optimize speed)) + (funcall fast-function (car args)))) + (2 + #'(lambda (args) + (declare (optimize speed)) + (funcall fast-function (car args) (cadr args))))) + ;; `(lambda (args) + ;; (declare (optimize speed)) + ;; (funcall ,(%method-function (car primaries)) args ,next-emfun)) + (generate-emf-lambda (%method-function (car primaries)) + next-emfun)))) + (t + (let ((method-function (%method-function (car primaries)))) + + #'(lambda (args) + (declare (optimize speed)) + (dolist (before befores) + (funcall (%method-function before) args nil)) + (multiple-value-prog1 + (funcall method-function args next-emfun) + (dolist (after reverse-afters) + (funcall (%method-function after) args nil)))))))))) (t (let ((mc-obj (get mc-name 'method-combination-object))) (unless mc-obj @@ -1539,9 +1545,9 @@ (coerce-to-function emf-form)))) (defun generate-emf-lambda (method-function next-emfun) - `(lambda (args) - (declare (optimize speed)) - (funcall ,method-function args ,next-emfun))) + #'(lambda (args) + (declare (optimize speed)) + (funcall method-function args next-emfun))) ;;; compute an effective method function from a list of primary methods: From ehuelsmann at common-lisp.net Sat Oct 10 13:12:11 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 10 Oct 2009 09:12:11 -0400 Subject: [armedbear-cvs] r12185 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 10 09:12:09 2009 New Revision: 12185 Log: Add stack effects to opcodes actually in use. Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp Sat Oct 10 09:12:09 2009 @@ -98,10 +98,10 @@ (define-opcode aload_1 43 1 1) (define-opcode aload_2 44 1 1) (define-opcode aload_3 45 1 1) -(define-opcode iaload 46 1 nil) -(define-opcode laload 47 1 nil) -(define-opcode faload 48 1 nil) -(define-opcode daload 49 1 nil) +(define-opcode iaload 46 1 -1) +(define-opcode laload 47 1 0) +(define-opcode faload 48 1 -1) +(define-opcode daload 49 1 0) (define-opcode aaload 50 1 -1) (define-opcode baload 51 1 nil) (define-opcode caload 52 1 nil) @@ -131,10 +131,10 @@ (define-opcode astore_1 76 1 -1) (define-opcode astore_2 77 1 -1) (define-opcode astore_3 78 1 -1) -(define-opcode iastore 79 1 nil) -(define-opcode lastore 80 1 nil) -(define-opcode fastore 81 1 nil) -(define-opcode dastore 82 1 nil) +(define-opcode iastore 79 1 -3) +(define-opcode lastore 80 1 -4) +(define-opcode fastore 81 1 -3) +(define-opcode dastore 82 1 -4) (define-opcode aastore 83 1 -3) (define-opcode bastore 84 1 nil) (define-opcode castore 85 1 nil) From ehuelsmann at common-lisp.net Sat Oct 10 13:21:07 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 10 Oct 2009 09:21:07 -0400 Subject: [armedbear-cvs] r12186 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 10 09:21:06 2009 New Revision: 12186 Log: Add the opcodes to the resolver table. 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 Oct 10 09:21:06 2009 @@ -1058,11 +1058,19 @@ 43 ; aload_1 44 ; aload_2 45 ; aload_3 + 46 ; iaload + 47 ; laload + 48 ; faload + 49 ; daload 50 ; aaload 75 ; astore_0 76 ; astore_1 77 ; astore_2 78 ; astore_3 + 79 ; iastore + 80 ; lastore + 81 ; fastore + 82 ; dastore 83 ; aastore 87 ; pop 88 ; pop2 From ehuelsmann at common-lisp.net Sat Oct 10 14:02:32 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 10 Oct 2009 10:02:32 -0400 Subject: [armedbear-cvs] r12187 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 10 10:02:31 2009 New Revision: 12187 Log: Reinstate two-way-stream functionality with Gray streams. Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Sat Oct 10 10:02:31 2009 @@ -545,6 +545,24 @@ (funcall *old-read-sequence* sequence stream :start start :end end) (stream-read-sequence stream sequence start end))) +(defstruct two-way-stream-g + input-stream output-stream) + +(defun gray-make-two-way-stream (in out) + (if (and (old-streamp in) (old-streamp out)) + (funcall *old-make-two-way-stream* in out) + (make-two-way-stream-g :input-stream in :output-stream out))) + +(defun gray-two-way-stream-input-stream (stream) + (if (old-streamp stream) + (funcall *old-two-way-stream-input-stream* stream) + (two-way-stream-g-input-stream stream))) + +(defun gray-two-way-stream-output-stream (stream) + (if (old-streamp stream) + (funcall *old-two-way-stream-output-stream* stream) + (two-way-stream-g-output-stream stream))) + (setf (symbol-function 'common-lisp::read-char) #'gray-read-char) (setf (symbol-function 'common-lisp::peek-char) #'gray-peek-char) (setf (symbol-function 'common-lisp::unread-char) #'gray-unread-char) @@ -571,5 +589,8 @@ (setf (symbol-function 'common-lisp::streamp) #'gray-streamp) (setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence) (setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence) +(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream) +(setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream) +(setf (symbol-function 'common-lisp::two-way-stream-output-stream) #'gray-two-way-stream-output-stream) (provide 'gray-streams) From ehuelsmann at common-lisp.net Sat Oct 10 17:55:35 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 10 Oct 2009 13:55:35 -0400 Subject: [armedbear-cvs] r12188 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 10 13:55:32 2009 New Revision: 12188 Log: Fix cl-bench BENCH-STRINGS/ADJUSTABLE: We can't unbox variables which are in the argument array, because all variables need to have the same type. 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 Oct 10 13:55:32 2009 @@ -4149,10 +4149,15 @@ (return-from derive-variable-representation)) (when type-supplied-p (setf (variable-declared-type variable) type)) + (when (or (variable-closure-index variable) + (variable-index variable)) + ;; variables in one of the arrays cannot be represented + ;; other than by the boxed representation LispObject + (return-from derive-variable-representation)) (let ((type (variable-declared-type variable))) (when (and (eq (variable-declared-type variable) :none) (eql (variable-writes variable) 0)) - (setf type (variable-derived-type variable))) + (variable-derived-type variable)) (cond ((neq type :none) (setf (variable-representation variable) (type-representation type)) @@ -4196,78 +4201,27 @@ (defun emit-move-to-variable (variable) (let ((representation (variable-representation variable))) - (flet ((emit-array-store (representation) - (emit (ecase representation - ((:int :boolean :char) - 'iastore) - (:long 'lastore) - (:float 'fastore) - (:double 'dastore) - ((nil) 'aastore))))) - (cond ((variable-register variable) - (emit (ecase (variable-representation variable) - ((:int :boolean :char) - 'istore) - (:long 'lstore) - (:float 'fstore) - (:double 'dstore) - ((nil) 'astore)) - (variable-register variable))) - ((variable-index variable) - (aload (compiland-argument-register *current-compiland*)) - (emit-swap representation nil) - (emit-push-constant-int (variable-index variable)) - (emit-swap representation :int) - (emit-array-store (variable-representation variable))) - ((variable-closure-index variable) - (aload (compiland-closure-register *current-compiland*)) - (emit-push-constant-int (variable-closure-index variable)) - (emit 'aaload) - (emit-swap representation nil) - (emit 'putfield +closure-binding-class+ "value" +lisp-object+)) - ((variable-environment variable) - (assert (not *file-compilation*)) - (emit 'getstatic *this-class* - (declare-object (variable-environment variable) - +lisp-environment+ - +lisp-environment-class+) - +lisp-environment+) - (emit 'swap) - (emit-push-variable-name variable) - (emit 'swap) - (emit-invokevirtual +lisp-environment-class+ "rebind" - (list +lisp-symbol+ +lisp-object+) - nil)) - (t - (assert nil)))))) - -(defun emit-push-variable (variable) - (flet ((emit-array-load (representation) - (emit (ecase representation - ((:int :boolean :char) - 'iaload) - (:long 'laload) - (:float 'faload) - (:double 'daload) - ((nil) 'aaload))))) (cond ((variable-register variable) (emit (ecase (variable-representation variable) - ((:int :boolean :char) - 'iload) - (:long 'lload) - (:float 'fload) - (:double 'dload) - ((nil) 'aload)) + ((:int :boolean :char) + 'istore) + (:long 'lstore) + (:float 'fstore) + (:double 'dstore) + ((nil) 'astore)) (variable-register variable))) ((variable-index variable) (aload (compiland-argument-register *current-compiland*)) + (emit-swap representation nil) (emit-push-constant-int (variable-index variable)) - (emit-array-load (variable-representation variable))) + (emit-swap representation :int) + (emit 'aastore)) ((variable-closure-index variable) (aload (compiland-closure-register *current-compiland*)) (emit-push-constant-int (variable-closure-index variable)) (emit 'aaload) - (emit 'getfield +closure-binding-class+ "value" +lisp-object+)) + (emit-swap representation nil) + (emit 'putfield +closure-binding-class+ "value" +lisp-object+)) ((variable-environment variable) (assert (not *file-compilation*)) (emit 'getstatic *this-class* @@ -4275,13 +4229,48 @@ +lisp-environment+ +lisp-environment-class+) +lisp-environment+) + (emit 'swap) (emit-push-variable-name variable) - (emit-invokevirtual +lisp-environment-class+ "lookup" - (list +lisp-object+) - +lisp-object+)) + (emit 'swap) + (emit-invokevirtual +lisp-environment-class+ "rebind" + (list +lisp-symbol+ +lisp-object+) + nil)) (t (assert nil))))) +(defun emit-push-variable (variable) + (cond ((variable-register variable) + (emit (ecase (variable-representation variable) + ((:int :boolean :char) + 'iload) + (:long 'lload) + (:float 'fload) + (:double 'dload) + ((nil) 'aload)) + (variable-register variable))) + ((variable-index variable) + (aload (compiland-argument-register *current-compiland*)) + (emit-push-constant-int (variable-index variable)) + (emit 'aaload)) + ((variable-closure-index variable) + (aload (compiland-closure-register *current-compiland*)) + (emit-push-constant-int (variable-closure-index variable)) + (emit 'aaload) + (emit 'getfield +closure-binding-class+ "value" +lisp-object+)) + ((variable-environment variable) + (assert (not *file-compilation*)) + (emit 'getstatic *this-class* + (declare-object (variable-environment variable) + +lisp-environment+ + +lisp-environment-class+) + +lisp-environment+) + (emit-push-variable-name variable) + (emit-invokevirtual +lisp-environment-class+ "lookup" + (list +lisp-object+) + +lisp-object+)) + (t + (assert nil)))) + (defknown p2-let-bindings (t) t) (defun p2-let-bindings (block) From ehuelsmann at common-lisp.net Sat Oct 10 20:56:38 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 10 Oct 2009 16:56:38 -0400 Subject: [armedbear-cvs] r12189 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 10 16:56:35 2009 New Revision: 12189 Log: Replace another MAKE-CLOSURE with a pre-compiled closure. 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 Sat Oct 10 16:56:35 2009 @@ -1326,17 +1326,19 @@ (funcall emfun args) (slow-method-lookup gf args)))))) (t - (make-closure - `(lambda (&rest args) + #'(lambda (&rest args) (declare (optimize speed)) - (unless (,(if exact '= '>=) (length args) ,number-required) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name ,gf)))) - (let ((emfun (get-cached-emf ,gf args))) + (let ((len (length args))) + (unless (or (and exact + (= len number-required)) + (>= len number-required)) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name gf))))) + (let ((emfun (get-cached-emf gf args))) (if emfun (funcall emfun args) - (slow-method-lookup ,gf args)))) nil)))))))) + (slow-method-lookup gf args))))))))))) (when (and (fboundp 'autocompile) (not (autoloadp 'compile))) From ehuelsmann at common-lisp.net Mon Oct 12 19:42:05 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 12 Oct 2009 15:42:05 -0400 Subject: [armedbear-cvs] r12190 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Oct 12 15:42:01 2009 New Revision: 12190 Log: Don't try to compile functions which are already compiled. 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 Oct 12 15:42:01 2009 @@ -1340,10 +1340,6 @@ (funcall emfun args) (slow-method-lookup gf args))))))))))) - (when (and (fboundp 'autocompile) - (not (autoloadp 'compile))) - (setf code (or (autocompile code) code))) - code)) (defun method-applicable-p (method args) From ehuelsmann at common-lisp.net Mon Oct 12 20:34:03 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 12 Oct 2009 16:34:03 -0400 Subject: [armedbear-cvs] r12191 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Oct 12 16:33:59 2009 New Revision: 12191 Log: Move non-exact closure generation to the outer scope, reducing the size of function STD-COMPUTE-DISCRIMINATING-FUNCTION. 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 Oct 12 16:33:59 2009 @@ -1239,9 +1239,9 @@ (exact (null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))))) - (cond - ((= number-required 1) - (if exact + (if exact + (cond + ((= number-required 1) (cond ((and (eq (generic-function-method-combination gf) 'standard) (= (length (generic-function-methods gf)) 1)) @@ -1275,70 +1275,46 @@ gf arg specialization)))) (if emfun (funcall emfun (list arg)) - (apply #'no-applicable-method gf (list arg))))) - )) - #'(lambda (&rest args) - (declare (optimize speed)) - (unless (>= (length args) 1) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name gf)))) - (let ((emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args)))))) - ((= number-required 2) - (if exact + (apply #'no-applicable-method gf (list arg)))))))) + ((= number-required 2) #'(lambda (arg1 arg2) (declare (optimize speed)) (let* ((args (list arg1 arg2)) (emfun (get-cached-emf gf args))) (if emfun (funcall emfun args) - (slow-method-lookup gf args)))) - #'(lambda (&rest args) - (declare (optimize speed)) - (unless (>= (length args) 2) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name gf)))) - (let ((emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args)))))) - ((= number-required 3) - (if exact + (slow-method-lookup gf args))))) + ((= number-required 3) #'(lambda (arg1 arg2 arg3) (declare (optimize speed)) (let* ((args (list arg1 arg2 arg3)) (emfun (get-cached-emf gf args))) (if emfun (funcall emfun args) - (slow-method-lookup gf args)))) + (slow-method-lookup gf args))))) + (t #'(lambda (&rest args) (declare (optimize speed)) - (unless (>= (length args) 3) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name gf)))) + (let ((len (length args))) + (unless (= len number-required) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name gf))))) (let ((emfun (get-cached-emf gf args))) (if emfun (funcall emfun args) (slow-method-lookup gf args)))))) - (t - #'(lambda (&rest args) - (declare (optimize speed)) - (let ((len (length args))) - (unless (or (and exact - (= len number-required)) - (>= len number-required)) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name gf))))) - (let ((emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args))))))))))) + #'(lambda (&rest args) + (declare (optimize speed)) + (let ((len (length args))) + (unless (>= len number-required) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name gf))))) + (let ((emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args)))))))))) code)) From vvoutilainen at common-lisp.net Tue Oct 13 19:32:49 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 13 Oct 2009 15:32:49 -0400 Subject: [armedbear-cvs] r12192 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Tue Oct 13 15:32:46 2009 New Revision: 12192 Log: Patch by Douglas R. Miles to improve performance after CHAR_MAX was increased from 255 to 64k. Added: trunk/abcl/src/org/armedbear/lisp/CharHashMap.java Modified: trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java trunk/abcl/src/org/armedbear/lisp/LispCharacter.java trunk/abcl/src/org/armedbear/lisp/Readtable.java Added: trunk/abcl/src/org/armedbear/lisp/CharHashMap.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/CharHashMap.java Tue Oct 13 15:32:46 2009 @@ -0,0 +1,72 @@ +package org.armedbear.lisp; + +import java.lang.reflect.Array; +import java.util.ArrayList; +import java.util.Arrays; +import java.util.Collection; +import java.util.HashMap; +import java.util.Iterator; +import java.util.List; +import java.util.Map; +import java.util.Set; + +public class CharHashMap { + + final public T[] constants; + final public T NULL; + final static int CACHE_SIZE = 256; + final HashMap backing; + public CharHashMap(Class componentType, T def) { + NULL = def; + constants = (T[]) Array.newInstance(componentType, CACHE_SIZE); + Arrays.fill(constants, NULL); + backing = new HashMap(); + } + + @Override + public Object clone() { + CharHashMap n = new CharHashMap(constants.getClass().getComponentType(),NULL); + System.arraycopy(constants,0, n.constants,0,CACHE_SIZE); + n.backing.putAll(backing); + return n; + } + + public T get(char key) { + if (key getCharIterator() { + return new Iterator() { + final Iterator carIt = backing.keySet().iterator(); + int charNum = -1; + public boolean hasNext() { + if ( charNum lispChars; static { + lispChars = new CharHashMap(LispCharacter.class,null){ + public LispCharacter get(char c) { + LispCharacter lc = super.get(c); + if (lc==null) { + lc = new LispCharacter(c); + put(c, lc); + } + return lc; + } + }; + constants = lispChars.constants; for (int i = constants.length; i-- > 0;) constants[i] = new LispCharacter((char)i); } @@ -51,7 +63,7 @@ { try { - return constants[c]; + return lispChars.get(c); } catch (ArrayIndexOutOfBoundsException e) { @@ -341,7 +353,7 @@ { int n = Fixnum.getValue(arg); if (n < CHAR_MAX) - return constants[n]; + return lispChars.get((char)n); else if (n <= Character.MAX_VALUE) return new LispCharacter((char)n); // SBCL signals a type-error here: "not of type (UNSIGNED-BYTE 8)" @@ -613,7 +625,7 @@ return "Rubout"; } if (c<0 || c>255) return null; - return constants[c].name; + return lispChars.get(c).name; } // ### char-name @@ -651,8 +663,7 @@ } static void setCharName(int settingChar, String string) { - if (settingChar>=CHAR_MAX) return; - LispCharacter c = constants[settingChar]; + LispCharacter c = lispChars.get((char)settingChar); c.name = string; namedToChar.put(string.toLowerCase(), c); } 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 Tue Oct 13 15:32:46 2009 @@ -32,6 +32,7 @@ */ package org.armedbear.lisp; +import java.util.Iterator; public class Readtable extends LispObject { @@ -42,9 +43,9 @@ public static final byte SYNTAX_TYPE_SINGLE_ESCAPE = 4; public static final byte SYNTAX_TYPE_MULTIPLE_ESCAPE = 5; - protected final byte[] syntax = new byte[CHAR_MAX]; - protected final LispObject[] readerMacroFunctions = new LispObject[CHAR_MAX]; - protected final DispatchTable[] dispatchTables = new DispatchTable[CHAR_MAX]; + protected final CharHashMap syntax = new CharHashMap(Byte.class,SYNTAX_TYPE_CONSTITUENT); + protected final CharHashMap readerMacroFunctions = new CharHashMap(LispObject.class,null); + protected final CharHashMap dispatchTables = new CharHashMap(DispatchTable.class,null); protected LispObject readtableCase; @@ -55,6 +56,7 @@ protected void initialize() { + Byte[] syntax = this.syntax.constants; syntax[9] = SYNTAX_TYPE_WHITESPACE; // tab syntax[10] = SYNTAX_TYPE_WHITESPACE; // linefeed syntax[12] = SYNTAX_TYPE_WHITESPACE; // form feed @@ -74,6 +76,7 @@ syntax['\\'] = SYNTAX_TYPE_SINGLE_ESCAPE; syntax['|'] = SYNTAX_TYPE_MULTIPLE_ESCAPE; + LispObject[] readerMacroFunctions = this.readerMacroFunctions.constants; readerMacroFunctions[';'] = LispReader.READ_COMMENT; readerMacroFunctions['"'] = LispReader.READ_STRING; readerMacroFunctions['('] = LispReader.READ_LIST; @@ -86,32 +89,32 @@ readerMacroFunctions[','] = Symbol.COMMA_MACRO; DispatchTable dt = new DispatchTable(); + LispObject[] dtfunctions = dt.functions.constants; + dtfunctions['('] = LispReader.SHARP_LEFT_PAREN; + dtfunctions['*'] = LispReader.SHARP_STAR; + dtfunctions['.'] = LispReader.SHARP_DOT; + dtfunctions[':'] = LispReader.SHARP_COLON; + dtfunctions['A'] = LispReader.SHARP_A; + dtfunctions['B'] = LispReader.SHARP_B; + dtfunctions['C'] = LispReader.SHARP_C; + dtfunctions['O'] = LispReader.SHARP_O; + dtfunctions['P'] = LispReader.SHARP_P; + dtfunctions['R'] = LispReader.SHARP_R; + dtfunctions['S'] = LispReader.SHARP_S; + dtfunctions['X'] = LispReader.SHARP_X; + dtfunctions['\''] = LispReader.SHARP_QUOTE; + dtfunctions['\\'] = LispReader.SHARP_BACKSLASH; + dtfunctions['|'] = LispReader.SHARP_VERTICAL_BAR; + dtfunctions[')'] = LispReader.SHARP_ILLEGAL; + dtfunctions['<'] = LispReader.SHARP_ILLEGAL; + dtfunctions[' '] = LispReader.SHARP_ILLEGAL; + dtfunctions[8] = LispReader.SHARP_ILLEGAL; // backspace + dtfunctions[9] = LispReader.SHARP_ILLEGAL; // tab + dtfunctions[10] = LispReader.SHARP_ILLEGAL; // newline, linefeed + dtfunctions[12] = LispReader.SHARP_ILLEGAL; // page + dtfunctions[13] = LispReader.SHARP_ILLEGAL; // return - dt.functions['('] = LispReader.SHARP_LEFT_PAREN; - dt.functions['*'] = LispReader.SHARP_STAR; - dt.functions['.'] = LispReader.SHARP_DOT; - dt.functions[':'] = LispReader.SHARP_COLON; - dt.functions['A'] = LispReader.SHARP_A; - dt.functions['B'] = LispReader.SHARP_B; - dt.functions['C'] = LispReader.SHARP_C; - dt.functions['O'] = LispReader.SHARP_O; - dt.functions['P'] = LispReader.SHARP_P; - dt.functions['R'] = LispReader.SHARP_R; - dt.functions['S'] = LispReader.SHARP_S; - dt.functions['X'] = LispReader.SHARP_X; - dt.functions['\''] = LispReader.SHARP_QUOTE; - dt.functions['\\'] = LispReader.SHARP_BACKSLASH; - dt.functions['|'] = LispReader.SHARP_VERTICAL_BAR; - dt.functions[')'] = LispReader.SHARP_ILLEGAL; - dt.functions['<'] = LispReader.SHARP_ILLEGAL; - dt.functions[' '] = LispReader.SHARP_ILLEGAL; - dt.functions[8] = LispReader.SHARP_ILLEGAL; // backspace - dt.functions[9] = LispReader.SHARP_ILLEGAL; // tab - dt.functions[10] = LispReader.SHARP_ILLEGAL; // newline, linefeed - dt.functions[12] = LispReader.SHARP_ILLEGAL; // page - dt.functions[13] = LispReader.SHARP_ILLEGAL; // return - - dispatchTables['#'] = dt; + dispatchTables.constants['#'] = dt; readtableCase = Keyword.UPCASE; } @@ -125,35 +128,44 @@ rt = checkReadtable(obj); synchronized (rt) { - System.arraycopy(rt.syntax, 0, syntax, 0, CHAR_MAX); - System.arraycopy(rt.readerMacroFunctions, 0, readerMacroFunctions, 0, - CHAR_MAX); - // Deep copy. - for (int i = dispatchTables.length; i-- > 0;) - { - DispatchTable dt = rt.dispatchTables[i]; - if (dt != null) - dispatchTables[i] = new DispatchTable(dt); - } - readtableCase = rt.readtableCase; + copyReadtable(rt, this); } } // FIXME synchronization private static void copyReadtable(Readtable from, Readtable to) { - System.arraycopy(from.syntax, 0, to.syntax, 0, CHAR_MAX); - System.arraycopy(from.readerMacroFunctions, 0, to.readerMacroFunctions, 0, - CHAR_MAX); - for (int i = from.dispatchTables.length; i-- > 0;) - { - DispatchTable dt = from.dispatchTables[i]; - if (dt != null) - to.dispatchTables[i] = new DispatchTable(dt); - else - to.dispatchTables[i] = null; + Iterator charIterator = from.syntax.getCharIterator(); + while (charIterator.hasNext()) { + char c = charIterator.next(); + Byte dt = from.syntax.get(c); + if (dt!=null) { + to.syntax.put(c, dt); + } else { + to.syntax.put(c, null); + } + } + charIterator = from.readerMacroFunctions.getCharIterator(); + while (charIterator.hasNext()) { + char c = charIterator.next(); + LispObject dt = from.readerMacroFunctions.get(c); + if (dt!=null) { + to.readerMacroFunctions.put(c, dt); + } else { + to.readerMacroFunctions.put(c, null); + } + } + charIterator = from.dispatchTables.getCharIterator(); + while (charIterator.hasNext()) { + char c = charIterator.next(); + DispatchTable dt = from.dispatchTables.get(c); + if (dt!=null) { + to.dispatchTables.put(c, new DispatchTable(dt)); + } else { + to.dispatchTables.put(c, null); + } } - to.readtableCase = from.readtableCase; + to.readtableCase = from.readtableCase; } @Override @@ -191,16 +203,12 @@ public boolean isWhitespace(char c) { - if (c < CHAR_MAX) - return syntax[c] == SYNTAX_TYPE_WHITESPACE; - return false; + return getSyntaxType(c) == SYNTAX_TYPE_WHITESPACE; } public byte getSyntaxType(char c) { - if (c < CHAR_MAX) - return syntax[c]; - return SYNTAX_TYPE_CONSTITUENT; + return syntax.get(c); } public boolean isInvalid(char c) @@ -239,10 +247,7 @@ public LispObject getReaderMacroFunction(char c) { - if (c < CHAR_MAX) - return readerMacroFunctions[c]; - else - return null; + return readerMacroFunctions.get(c); } private LispObject getMacroCharacter(char c) throws ConditionThrowable @@ -251,7 +256,7 @@ LispObject non_terminating_p; if (function != null) { - if (syntax[c] == SYNTAX_TYPE_NON_TERMINATING_MACRO) + if (syntax.get(c) == SYNTAX_TYPE_NON_TERMINATING_MACRO) non_terminating_p = T; else non_terminating_p = NIL; @@ -272,15 +277,15 @@ else syntaxType = SYNTAX_TYPE_TERMINATING_MACRO; // FIXME synchronization - syntax[dispChar] = syntaxType; - readerMacroFunctions[dispChar] = LispReader.READ_DISPATCH_CHAR; - dispatchTables[dispChar] = new DispatchTable(); + syntax.put(dispChar,syntaxType); + readerMacroFunctions.put(dispChar, LispReader.READ_DISPATCH_CHAR); + dispatchTables.put(dispChar, new DispatchTable()); } public LispObject getDispatchMacroCharacter(char dispChar, char subChar) throws ConditionThrowable { - DispatchTable dispatchTable = dispatchTables[dispChar]; + DispatchTable dispatchTable = dispatchTables.get(dispChar); if (dispatchTable == null) { LispCharacter c = LispCharacter.getInstance(dispChar); @@ -288,7 +293,7 @@ " is not a dispatch character.")); } LispObject function = - dispatchTable.functions[LispCharacter.toUpperCase(subChar)]; + dispatchTable.functions.get(LispCharacter.toUpperCase(subChar)); return (function != null) ? function : NIL; } @@ -296,28 +301,28 @@ LispObject function) throws ConditionThrowable { - DispatchTable dispatchTable = dispatchTables[dispChar]; + DispatchTable dispatchTable = dispatchTables.get(dispChar); if (dispatchTable == null) { LispCharacter c = LispCharacter.getInstance(dispChar); error(new LispError(c.writeToString() + " is not a dispatch character.")); } - dispatchTable.functions[LispCharacter.toUpperCase(subChar)] = function; + dispatchTable.functions.put(LispCharacter.toUpperCase(subChar), function); } protected static class DispatchTable { - public LispObject[] functions = new LispObject[CHAR_MAX]; + protected final CharHashMap functions; public DispatchTable() { + functions = new CharHashMap(LispObject.class,null); } public DispatchTable(DispatchTable dt) { - for (int i = 0; i < functions.length; i++) - functions[i] = dt.functions[i]; + functions = (CharHashMap) dt.functions.clone(); } } @@ -427,8 +432,8 @@ syntaxType = SYNTAX_TYPE_TERMINATING_MACRO; Readtable rt = designator_readtable(fourth); // REVIEW synchronization - rt.syntax[c] = syntaxType; - rt.readerMacroFunctions[c] = designator; + rt.syntax.put(c, syntaxType); + rt.readerMacroFunctions.put(c, designator); return T; } }; @@ -530,20 +535,18 @@ else fromReadtable = checkReadtable(STANDARD_READTABLE.symbolValue()); // REVIEW synchronization - toReadtable.syntax[toChar] = fromReadtable.syntax[fromChar]; - toReadtable.readerMacroFunctions[toChar] = - fromReadtable.readerMacroFunctions[fromChar]; + toReadtable.syntax.put(toChar, fromReadtable.syntax.get(fromChar)); + toReadtable.readerMacroFunctions.put(toChar, + fromReadtable.readerMacroFunctions.get(fromChar)); // "If the character is a dispatching macro character, its entire // dispatch table of reader macro functions is copied." - if (fromReadtable.dispatchTables[fromChar] != null) - { - toReadtable.dispatchTables[toChar] = - new DispatchTable(fromReadtable.dispatchTables[fromChar]); - } + DispatchTable found = fromReadtable.dispatchTables.get(fromChar); + if (found!=null) + toReadtable.dispatchTables.put(toChar, new DispatchTable(found)); else // Don't leave behind dispatch tables when fromChar // doesn't have one - toReadtable.dispatchTables[toChar] = null; + toReadtable.dispatchTables.put(toChar, null); return T; } }; From ehuelsmann at common-lisp.net Tue Oct 13 22:09:17 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 13 Oct 2009 18:09:17 -0400 Subject: [armedbear-cvs] r12193 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Oct 13 18:09:14 2009 New Revision: 12193 Log: Fix temp file leakage. Note: this change is mostly for backport to 0.16.x, because the real change is to add a source for semi-unique class names. 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 Tue Oct 13 18:09:14 2009 @@ -4946,18 +4946,20 @@ (let* ((pathname (funcall *pathnames-generator*)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) - (with-open-class-file (f class-file) - (set-compiland-and-write-class class-file compiland f)) + (with-open-class-file (f class-file) + (set-compiland-and-write-class class-file compiland f)) (setf (local-function-class-file local-function) class-file))) (t - (let ((class-file (make-class-file - :pathname (funcall *pathnames-generator*) - :lambda-list lambda-list))) - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (set-compiland-and-write-class class-file compiland stream) - (setf (local-function-class-file local-function) class-file) - (setf (local-function-function local-function) - (load-compiled-function (sys::%get-output-stream-bytes stream))))))))) + (let ((class-file (make-class-file + :pathname (funcall *pathnames-generator*) + :lambda-list lambda-list))) + (unwind-protect + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (set-compiland-and-write-class class-file compiland stream) + (setf (local-function-class-file local-function) class-file) + (setf (local-function-function local-function) + (load-compiled-function (sys::%get-output-stream-bytes stream)))) + (delete-file (class-file-pathname class-file)))))))) (defun emit-make-compiled-closure-for-labels (local-function compiland declaration) @@ -4981,24 +4983,26 @@ (let* ((pathname (funcall *pathnames-generator*)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) - (with-open-class-file (f class-file) - (set-compiland-and-write-class class-file compiland f)) + (with-open-class-file (f class-file) + (set-compiland-and-write-class class-file compiland f)) (setf (local-function-class-file local-function) class-file) (let ((g (declare-local-function local-function))) - (emit-make-compiled-closure-for-labels - local-function compiland g)))) + (emit-make-compiled-closure-for-labels + local-function compiland g)))) (t - (let ((class-file (make-class-file - :pathname (funcall *pathnames-generator*) - :lambda-list lambda-list))) - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (set-compiland-and-write-class class-file compiland stream) - (setf (local-function-class-file local-function) class-file) - (let ((g (declare-object - (load-compiled-function - (sys::%get-output-stream-bytes stream))))) - (emit-make-compiled-closure-for-labels - local-function compiland g)))))))) + (let ((class-file (make-class-file + :pathname (funcall *pathnames-generator*) + :lambda-list lambda-list))) + (unwind-protect + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (set-compiland-and-write-class class-file compiland stream) + (setf (local-function-class-file local-function) class-file) + (let ((g (declare-object + (load-compiled-function + (sys::%get-output-stream-bytes stream))))) + (emit-make-compiled-closure-for-labels + local-function compiland g))) + (delete-file (class-file-pathname class-file)))))))) (defknown p2-flet-node (t t t) t) (defun p2-flet-node (block target representation) @@ -5057,13 +5061,15 @@ (setf (compiland-class-file compiland) (make-class-file :pathname pathname :lambda-list lambda-list)) - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (compile-and-write-to-stream (compiland-class-file compiland) - compiland stream) - (emit 'getstatic *this-class* - (declare-object (load-compiled-function - (sys::%get-output-stream-bytes stream))) - +lisp-object+))))) + (unwind-protect + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (compile-and-write-to-stream (compiland-class-file compiland) + compiland stream) + (emit 'getstatic *this-class* + (declare-object (load-compiled-function + (sys::%get-output-stream-bytes stream))) + +lisp-object+)) + (delete-file pathname))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) (duplicate-closure-array *current-compiland*) @@ -8524,24 +8530,24 @@ (defun %jvm-compile (name definition expr env) (let* (compiled-function (tempfile (make-temp-file))) - (with-compilation-unit () - (with-saved-compiler-policy - (setf compiled-function - (load-compiled-function - (if *file-compilation* - (unwind-protect - (progn - (with-open-file (f tempfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (compile-defun name expr env tempfile f)) - tempfile) - (delete-file tempfile)) - (with-open-stream (s (sys::%make-byte-array-output-stream)) - (compile-defun name expr env tempfile s) - (finish-output s) - (sys::%get-output-stream-bytes s))))))) + (unwind-protect + (with-compilation-unit () + (with-saved-compiler-policy + (setf compiled-function + (load-compiled-function + (if *file-compilation* + (progn + (with-open-file (f tempfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (compile-defun name expr env tempfile f)) + tempfile) + (with-open-stream (s (sys::%make-byte-array-output-stream)) + (compile-defun name expr env tempfile s) + (finish-output s) + (sys::%get-output-stream-bytes s))))))) + (delete-file tempfile)) (when (and name (functionp compiled-function)) (sys::set-function-definition name compiled-function definition)) (or name compiled-function))) From vvoutilainen at common-lisp.net Wed Oct 14 19:58:27 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Wed, 14 Oct 2009 15:58:27 -0400 Subject: [armedbear-cvs] r12194 - in branches/0.16.x/abcl: . src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Wed Oct 14 15:58:24 2009 New Revision: 12194 Log: Fix leakage of temp files during compilation. Modified: branches/0.16.x/abcl/CHANGES branches/0.16.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/0.16.x/abcl/CHANGES ============================================================================== --- branches/0.16.x/abcl/CHANGES (original) +++ branches/0.16.x/abcl/CHANGES Wed Oct 14 15:58:24 2009 @@ -7,6 +7,7 @@ * More careful checking for null args in LispStackFrame * Honor appearance of &allow-other-keys in CLOS MAKE-INSTANCE * Fix #63: GO forms to non-existent TAGBODY labels would exit ABCL + * Don't leak temp files during compilation. Version 0.16.0 svn://common-lisp.net/project/armedbear/svn/tags/0.16.0/abcl Modified: branches/0.16.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/0.16.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/0.16.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Oct 14 15:58:24 2009 @@ -8474,8 +8474,8 @@ (unwind-protect (setf compiled-function (load-compiled-function - (compile-defun name expr env tempfile)))) - (delete-file tempfile))) + (compile-defun name expr env tempfile))) + (delete-file tempfile)))) (when (and name (functionp compiled-function)) (sys::set-function-definition name compiled-function definition)) (or name compiled-function))) From ehuelsmann at common-lisp.net Thu Oct 15 20:35:09 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 15 Oct 2009 16:35:09 -0400 Subject: [armedbear-cvs] r12195 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Oct 15 16:35:05 2009 New Revision: 12195 Log: Remove temp file creation which was solely used for generation of unique names. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.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 Thu Oct 15 16:35:05 2009 @@ -4950,16 +4950,13 @@ (set-compiland-and-write-class class-file compiland f)) (setf (local-function-class-file local-function) class-file))) (t - (let ((class-file (make-class-file - :pathname (funcall *pathnames-generator*) - :lambda-list lambda-list))) - (unwind-protect - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (set-compiland-and-write-class class-file compiland stream) - (setf (local-function-class-file local-function) class-file) - (setf (local-function-function local-function) - (load-compiled-function (sys::%get-output-stream-bytes stream)))) - (delete-file (class-file-pathname class-file)))))))) + (let ((class-file (make-class-file :lambda-list lambda-list))) + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (set-compiland-and-write-class class-file compiland stream) + (setf (local-function-class-file local-function) class-file) + (setf (local-function-function local-function) + (load-compiled-function + (sys::%get-output-stream-bytes stream))))))))) (defun emit-make-compiled-closure-for-labels (local-function compiland declaration) @@ -4990,19 +4987,15 @@ (emit-make-compiled-closure-for-labels local-function compiland g)))) (t - (let ((class-file (make-class-file - :pathname (funcall *pathnames-generator*) - :lambda-list lambda-list))) - (unwind-protect - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (set-compiland-and-write-class class-file compiland stream) - (setf (local-function-class-file local-function) class-file) - (let ((g (declare-object - (load-compiled-function - (sys::%get-output-stream-bytes stream))))) - (emit-make-compiled-closure-for-labels - local-function compiland g))) - (delete-file (class-file-pathname class-file)))))))) + (let ((class-file (make-class-file :lambda-list lambda-list))) + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (set-compiland-and-write-class class-file compiland stream) + (setf (local-function-class-file local-function) class-file) + (let ((g (declare-object + (load-compiled-function + (sys::%get-output-stream-bytes stream))))) + (emit-make-compiled-closure-for-labels + local-function compiland g)))))))) (defknown p2-flet-node (t t t) t) (defun p2-flet-node (block target representation) @@ -5057,19 +5050,15 @@ class-file)) +lisp-object+))) (t - (let ((pathname (funcall *pathnames-generator*))) - (setf (compiland-class-file compiland) - (make-class-file :pathname pathname - :lambda-list lambda-list)) - (unwind-protect - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (compile-and-write-to-stream (compiland-class-file compiland) - compiland stream) - (emit 'getstatic *this-class* - (declare-object (load-compiled-function - (sys::%get-output-stream-bytes stream))) - +lisp-object+)) - (delete-file pathname))))) + (setf (compiland-class-file compiland) + (make-class-file :lambda-list lambda-list)) + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (compile-and-write-to-stream (compiland-class-file compiland) + compiland stream) + (emit 'getstatic *this-class* + (declare-object (load-compiled-function + (sys::%get-output-stream-bytes stream))) + +lisp-object+)))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) (duplicate-closure-array *current-compiland*) @@ -8416,6 +8405,9 @@ (error 'program-error :format-control "Execution of a form compiled with errors."))) (defun compile-defun (name form environment filespec stream) + "Compiles a lambda expression `form'. If `filespec' is NIL, +a random Java class name is generated, if it is non-NIL, it's used +to derive a Java class name from." (aver (eq (car form) 'LAMBDA)) (catch 'compile-defun-abort (let* ((class-file (make-class-file :pathname filespec @@ -8528,32 +8520,25 @@ (defun %jvm-compile (name definition expr env) - (let* (compiled-function - (tempfile (make-temp-file))) - (unwind-protect - (with-compilation-unit () - (with-saved-compiler-policy - (setf compiled-function - (load-compiled-function - (if *file-compilation* - (progn - (with-open-file (f tempfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (compile-defun name expr env tempfile f)) - tempfile) - (with-open-stream (s (sys::%make-byte-array-output-stream)) - (compile-defun name expr env tempfile s) - (finish-output s) - (sys::%get-output-stream-bytes s))))))) - (delete-file tempfile)) + ;; This function is part of the call chain from COMPILE, but + ;; not COMPILE-FILE + (let* (compiled-function) + (with-compilation-unit () + (with-saved-compiler-policy + (setf compiled-function + (load-compiled-function + (with-open-stream (s (sys::%make-byte-array-output-stream)) + (compile-defun name expr env nil s) + (finish-output s) + (sys::%get-output-stream-bytes s)))))) (when (and name (functionp compiled-function)) (sys::set-function-definition name compiled-function definition)) (or name compiled-function))) (defun jvm-compile (name &optional definition) + ;; This function is part of the call chain from COMPILE, but + ;; not COMPILE-FILE (unless definition (resolve name) ;; Make sure the symbol has been resolved by the autoloader (setf definition (fdefinition name))) @@ -8567,7 +8552,7 @@ (*file-compilation* nil) (*visible-variables* nil) (*local-functions* nil) - (*pathnames-generator* #'make-temp-file) + (*pathnames-generator* (constantly nil)) (sys::*fasl-anonymous-package* (sys::%make-package)) environment) (unless (and (consp definition) (eq (car definition) 'LAMBDA)) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Thu Oct 15 16:35:05 2009 @@ -117,12 +117,26 @@ (setf (char name i) #\_))) (concatenate 'string "org/armedbear/lisp/" name))) +(defun make-unique-class-name () + "Creates a random class name for use with a `class-file' structure's +`class' slot." + (concatenate 'string "abcl_" + (java:jcall (java:jmethod "java.lang.String" "replace" "char" "char") + (java:jcall (java:jmethod "java.util.UUID" "toString") + (java:jstatic "randomUUID" "java.util.UUID")) + #\- #\_))) + (defun make-class-file (&key pathname lambda-name lambda-list) - (aver (not (null pathname))) - (let ((class-file (%make-class-file :pathname pathname - :lambda-name lambda-name - :lambda-list lambda-list))) - (setf (class-file-class class-file) (class-name-from-filespec pathname)) + "Creates a `class-file' structure. If `pathname' is non-NIL, it's +used to derive a class name. If it is NIL, a random one created +using `make-unique-class-name'." + (let* ((class-name (if pathname + (class-name-from-filespec pathname) + (make-unique-class-name))) + (class-file (%make-class-file :pathname pathname + :class class-name + :lambda-name lambda-name + :lambda-list lambda-list))) class-file)) (defmacro with-class-file (class-file &body body) From ehuelsmann at common-lisp.net Thu Oct 15 20:53:49 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 15 Oct 2009 16:53:49 -0400 Subject: [armedbear-cvs] r12196 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Oct 15 16:53:48 2009 New Revision: 12196 Log: Suppress unchecked warnings with arrays, because there's no other solution. Increment by dmiles (on his own patch for more memory-efficient readtables). Modified: trunk/abcl/src/org/armedbear/lisp/CharHashMap.java trunk/abcl/src/org/armedbear/lisp/Readtable.java Modified: trunk/abcl/src/org/armedbear/lisp/CharHashMap.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CharHashMap.java (original) +++ trunk/abcl/src/org/armedbear/lisp/CharHashMap.java Thu Oct 15 16:53:48 2009 @@ -16,6 +16,8 @@ final public T NULL; final static int CACHE_SIZE = 256; final HashMap backing; + + @SuppressWarnings("unchecked") public CharHashMap(Class componentType, T def) { NULL = def; constants = (T[]) Array.newInstance(componentType, CACHE_SIZE); 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 Thu Oct 15 16:53:48 2009 @@ -320,6 +320,7 @@ functions = new CharHashMap(LispObject.class,null); } + @SuppressWarnings("unchecked") public DispatchTable(DispatchTable dt) { functions = (CharHashMap) dt.functions.clone(); From ehuelsmann at common-lisp.net Sat Oct 17 09:51:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 05:51:02 -0400 Subject: [armedbear-cvs] r12197 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Oct 17 05:50:59 2009 New Revision: 12197 Log: Correct speling error found by lpolzer. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sat Oct 17 05:50:59 2009 @@ -30,7 +30,7 @@ -- create executable wrapper for ABCL. abcl.source.zip abcl.source.tar -- create source distributions in ${dist.dir}. - acbl.test.java + abcl.test.java -- Run junit tests under ${abcl.test.src.dir}. abcl.clean -- remove ABCL intermediate files From ehuelsmann at common-lisp.net Sat Oct 17 11:44:29 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 07:44:29 -0400 Subject: [armedbear-cvs] r12198 - in branches/0.16.x/abcl: . src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 17 07:44:27 2009 New Revision: 12198 Log: Update CHANGES. Modified: branches/0.16.x/abcl/CHANGES branches/0.16.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.16.x/abcl/CHANGES ============================================================================== --- branches/0.16.x/abcl/CHANGES (original) +++ branches/0.16.x/abcl/CHANGES Sat Oct 17 07:44:27 2009 @@ -1,6 +1,6 @@ Version 0.16.1 -svn://common-lisp.net/project/armedbear/svn/branches/0.16.x/abcl -(Unreleased) +svn://common-lisp.net/project/armedbear/svn/tags/0.16.1/abcl +(17 Oct, 2009) Bugs fixed: Modified: branches/0.16.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.16.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.16.x/abcl/src/org/armedbear/lisp/Version.java Sat Oct 17 07:44:27 2009 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.16.1-dev"; + return "0.16.1"; } } From ehuelsmann at common-lisp.net Sat Oct 17 11:45:47 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 07:45:47 -0400 Subject: [armedbear-cvs] r12199 - tags/0.16.1 Message-ID: Author: ehuelsmann Date: Sat Oct 17 07:45:46 2009 New Revision: 12199 Log: Create tag for 0.16.1. Added: tags/0.16.1/ - copied from r12198, /branches/0.16.x/ From ehuelsmann at common-lisp.net Sat Oct 17 11:46:41 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 07:46:41 -0400 Subject: [armedbear-cvs] r12200 - branches/0.16.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 17 07:46:40 2009 New Revision: 12200 Log: Update version number on 0.16 branch. Modified: branches/0.16.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.16.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.16.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.16.x/abcl/src/org/armedbear/lisp/Version.java Sat Oct 17 07:46:40 2009 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.16.1"; + return "0.16.2-dev"; } } From ehuelsmann at common-lisp.net Sat Oct 17 12:00:14 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 08:00:14 -0400 Subject: [armedbear-cvs] r12201 - public_html/releases Message-ID: Author: ehuelsmann Date: Sat Oct 17 08:00:06 2009 New Revision: 12201 Log: Add distribution archives. Added: public_html/releases/abcl-src-0.16.1.tar.gz (contents, props changed) public_html/releases/abcl-src-0.16.1.tar.gz.asc public_html/releases/abcl-src-0.16.1.zip (contents, props changed) public_html/releases/abcl-src-0.16.1.zip.asc Added: public_html/releases/abcl-src-0.16.1.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.16.1.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.16.1.tar.gz.asc Sat Oct 17 08:00:06 2009 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkrZsJIACgkQi5O0Epaz9TnvZACeIR1BKdToeG/ZhC6ShUb7aDTk +9g4Anj4PqbBw0EstPwr61UTy6+hIM5KF +=C66K +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.16.1.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.16.1.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.16.1.zip.asc Sat Oct 17 08:00:06 2009 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkrZsJsACgkQi5O0Epaz9TlebgCfQo5PpuuNZkmI/9vZcxSAvSc2 +xGIAnR5Rv3e2QFoeW0J0YfnjItokxem2 +=JfY9 +-----END PGP SIGNATURE----- From ehuelsmann at common-lisp.net Sat Oct 17 19:35:19 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 15:35:19 -0400 Subject: [armedbear-cvs] r12202 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 17 15:35:16 2009 New Revision: 12202 Log: Fix ABCL as a build-host for SBCL: Don't return "FAILURE-P" == T in case of a style warning. 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 Sat Oct 17 15:35:16 2009 @@ -475,15 +475,19 @@ :stream out) (%stream-terpri out)) (handler-bind ((style-warning #'(lambda (c) - (declare (ignore c)) (setf warnings-p t) - nil)) + ;; let outer handlers + ;; do their thing + (signal c) + ;; prevent the next + ;; handler from running: + ;; we're a WARNING subclass + (continue))) ((or warning compiler-error) #'(lambda (c) (declare (ignore c)) (setf warnings-p t - failure-p t) - nil))) + failure-p t)))) (loop (let* ((*source-position* (file-position in)) (jvm::*source-line-number* (stream-line-number in)) From ehuelsmann at common-lisp.net Sat Oct 17 19:43:20 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 15:43:20 -0400 Subject: [armedbear-cvs] r12203 - public_html Message-ID: Author: ehuelsmann Date: Sat Oct 17 15:43:18 2009 New Revision: 12203 Log: Publish 0.16.1. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sat Oct 17 15:43:18 2009 @@ -32,9 +32,9 @@ using Java to Lisp integration APIs. -Download 0.16.0 +Download 0.16.1 (zip) Users From ehuelsmann at common-lisp.net Sat Oct 17 20:28:51 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 16:28:51 -0400 Subject: [armedbear-cvs] r12204 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Oct 17 16:28:50 2009 New Revision: 12204 Log: Update CHANGES with what happened toward 0.17.0 for now. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sat Oct 17 16:28:50 2009 @@ -2,16 +2,40 @@ ============== (unreleased) -Features --------- +Features: - * Support for loading FASLs from JAR files. + * Support for loading FASLs from JAR files + * Checking of init-arguments for MAKE-INSTANCE (CLOS) + * Support for *INVOKE-DEBUGGER-HOOK* (to support SLIME) + + +Bugs fixed: + + * Better fix for #63: Prevent exceptions from happening (GO and RETURN-FROM) + * Restore ability for ABCL to be build host for SBCL + * CLOS performance improvements through looser COMPILE dependency + * Compilation fix for highest SPEED setting (triggered by CL-BENCH) + * COMPILE's use of temp files eliminated + * OpenJDK on Darwin now correctly identified + * Incorrect block names for SETF functions defined by LABELS + * Fixed MULTIPLE-VALUE-CALL with more than 8 arguments + * Incorrect identification of lexical scope on recursive TAGBODY/GO + and BLOCK/RETURN-FROM blocks (compiler and interpreter) + * Correctly return 65k in char-code-limit (was 256, incorrectly) + * + + +Version 0.16.1 +============== +svn://common-lisp.net/project/armedbear/svn/tags/0.16.1/abcl +(17 Oct, 2009) + +Bugs fixed: -Bugs fixed ----------- * More careful checking for null args in LispStackFrame * Honor appearance of &allow-other-keys in CLOS MAKE-INSTANCE * Fix #63: GO forms to non-existent TAGBODY labels would exit ABCL + * Don't leak temp files during compilation Version 0.16.0 ============== From ehuelsmann at common-lisp.net Sat Oct 17 21:08:36 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 17:08:36 -0400 Subject: [armedbear-cvs] r12205 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 17 17:08:35 2009 New Revision: 12205 Log: Fix hard crashes in BEYOND-ANSI tests. Note: Don't cheer too hard; there are 158 tests failing (out of 527). Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java trunk/abcl/src/org/armedbear/lisp/StandardObject.java Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Sat Oct 17 17:08:35 2009 @@ -47,7 +47,7 @@ { if (args.cdr() != NIL) return error(new WrongNumberOfArgumentsException(this)); - return ((Cons)args).car; + return args.car(); } }; Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sat Oct 17 17:08:35 2009 @@ -252,7 +252,9 @@ } Debug.assertTrue(layout != null); int index = layout.getSlotIndex(slotName); - Debug.assertTrue(index >= 0); + //### FIXME: should call SLOT-MISSING (clhs) + if (index < 0) + return error(new LispError("Missing slot " + slotName.writeToString())); return slots[index]; } @@ -268,7 +270,9 @@ } Debug.assertTrue(layout != null); int index = layout.getSlotIndex(slotName); - Debug.assertTrue(index >= 0); + //### FIXME: should call SLOT-MISSING (clhs) + if (index < 0) + error(new LispError("Missing slot " + slotName.writeToString())); slots[index] = newValue; } From ehuelsmann at common-lisp.net Sat Oct 17 21:11:01 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 17:11:01 -0400 Subject: [armedbear-cvs] r12206 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Oct 17 17:11:00 2009 New Revision: 12206 Log: Update CHANGES. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sat Oct 17 17:11:00 2009 @@ -22,7 +22,7 @@ * Incorrect identification of lexical scope on recursive TAGBODY/GO and BLOCK/RETURN-FROM blocks (compiler and interpreter) * Correctly return 65k in char-code-limit (was 256, incorrectly) - * + * Fixes to be able to run the BEYOND-ANSI tests (part of ANSI test suite) Version 0.16.1 From ehuelsmann at common-lisp.net Sat Oct 17 21:33:35 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 17:33:35 -0400 Subject: [armedbear-cvs] r12207 - public_html Message-ID: Author: ehuelsmann Date: Sat Oct 17 17:33:33 2009 New Revision: 12207 Log: Add 'commercial support' page. Note: I consulted other developers, but am not aware of any wanting to provide this kind of support. By no means am I claiming a monopoly position here. Added: public_html/commercial-support.shtml Modified: public_html/left-menu Added: public_html/commercial-support.shtml ============================================================================== --- (empty file) +++ public_html/commercial-support.shtml Sat Oct 17 17:33:33 2009 @@ -0,0 +1,53 @@ + + + + + Armed Bear Common Lisp (ABCL) - Commercial support + + + + + + +
+

Armed Bear Common Lisp (ABCL) - Commercial support

+
+ + + +
+

ABCL is being developed as open source. Each of the contributers chooses + his orher own priorities based on criteria like complexity and time + available. Many changes implemented over the past year were implemented + in evening hours, limiting the size and type of issue that can be addressed. +

+ +

Your priorities may not necessarily coincide with the priorities of the + developers. To make sure your needs will be addressed too, there is the + option of paid support. You may want to use this option for example in + case the 'regular' route (submission of a bug report or enhancement request) + isn't being addressed as quickly as you like. +

+ +

If you decide you want to use this option, please contact me directly at + ehuelsmann 'at' common-lisp 'dot' net. +

+ + +

Other developers are free to get their names added + to this list, but at this point no other developers are known to + want to provide this type of support.

+ +
+ + +
$Id: index.shtml 12203 2009-10-17 19:43:18Z ehuelsmann $
+ + + Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Sat Oct 17 17:33:33 2009 @@ -1,7 +1,8 @@
Project page
Testimonials
-Release notes +Release notes
+Paid support

From ehuelsmann at common-lisp.net Sat Oct 17 21:43:53 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 17 Oct 2009 17:43:53 -0400 Subject: [armedbear-cvs] r12208 - public_html Message-ID: Author: ehuelsmann Date: Sat Oct 17 17:43:51 2009 New Revision: 12208 Log: Formatting fix. Modified: public_html/commercial-support.shtml Modified: public_html/commercial-support.shtml ============================================================================== --- public_html/commercial-support.shtml (original) +++ public_html/commercial-support.shtml Sat Oct 17 17:43:51 2009 @@ -19,9 +19,13 @@

Armed Bear Common Lisp (ABCL) - Commercial support

+ -
+
+ +

Paid support

+

ABCL is being developed as open source. Each of the contributers chooses his orher own priorities based on criteria like complexity and time available. Many changes implemented over the past year were implemented @@ -35,7 +39,8 @@ isn't being addressed as quickly as you like.

-

If you decide you want to use this option, please contact me directly at +

If you decide you want to use this option, or have other needs related + to abcl, please contact me directly at ehuelsmann 'at' common-lisp 'dot' net.

@@ -47,6 +52,13 @@
+
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
$Id: index.shtml 12203 2009-10-17 19:43:18Z ehuelsmann $
From ehuelsmann at common-lisp.net Wed Oct 21 21:45:29 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 21 Oct 2009 17:45:29 -0400 Subject: [armedbear-cvs] r12209 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Oct 21 17:45:26 2009 New Revision: 12209 Log: Reduce abcl.jar by ~10% and the number of objects in it by ~13%. Note: This is due to the fact that single function calls no longer get compiled into lambda functions, but instead will be interpreted. For more information, study opcodes.abcl before and after this change. 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 Wed Oct 21 17:45:26 2009 @@ -372,6 +372,22 @@ (declaim (ftype (function (t) t) convert-toplevel-form)) (defun convert-toplevel-form (form) + (when (and (consp form) + (every #'(lambda (arg) + (or (and (atom arg) + (not (and (symbolp arg) + (symbol-macro-p arg)))) + (and (consp arg) + (eq 'QUOTE (car arg))))) + (cdr form))) + ;; single form with simple or constant arguments + ;; Without this exception, toplevel function calls + ;; will be compiled into lambdas which get compiled to + ;; compiled-functions. Those need to be loaded. + ;; Conclusion: Top level interpreting the function call + ;; and its arguments may be (and should be) more efficient. + (return-from convert-toplevel-form + (precompiler:precompile-form form nil *compile-file-environment*))) (let* ((expr `(lambda () ,form)) (classfile (next-classfile-name)) (result From ehuelsmann at common-lisp.net Thu Oct 22 20:25:39 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 22 Oct 2009 16:25:39 -0400 Subject: [armedbear-cvs] r12210 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Oct 22 16:25:36 2009 New Revision: 12210 Log: Save locally established special binding for quick access. Note: This commit speeds up COMPILE by quite a bit; it improves the performance of the ANSI tests by ~ 10% (which do more than just COMPILE). Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java trunk/abcl/src/org/armedbear/lisp/SpecialBinding.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Thu Oct 22 16:25:36 2009 @@ -316,24 +316,24 @@ return obj; } - public final void bindSpecial(Symbol name, LispObject value) + public final SpecialBinding bindSpecial(Symbol name, LispObject value) { - lastSpecialBinding = new SpecialBinding(name, value, lastSpecialBinding); + return lastSpecialBinding + = new SpecialBinding(name, value, lastSpecialBinding); } - public final void bindSpecialToCurrentValue(Symbol name) + public final SpecialBinding bindSpecialToCurrentValue(Symbol name) { SpecialBinding binding = lastSpecialBinding; while (binding != null) { if (binding.name == name) { - lastSpecialBinding = + return lastSpecialBinding = new SpecialBinding(name, binding.value, lastSpecialBinding); - return; } binding = binding.next; } // Not found. - lastSpecialBinding = + return lastSpecialBinding = new SpecialBinding(name, name.getSymbolValue(), lastSpecialBinding); } Modified: trunk/abcl/src/org/armedbear/lisp/SpecialBinding.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialBinding.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SpecialBinding.java Thu Oct 22 16:25:36 2009 @@ -37,7 +37,7 @@ final public class SpecialBinding { final LispObject name; - LispObject value; + public LispObject value; final SpecialBinding next; SpecialBinding(LispObject name, LispObject value, SpecialBinding next) @@ -46,4 +46,18 @@ this.value = value; this.next = next; } + + /** Return the value of the binding, + * checking a valid binding. + * + * If the binding is invalid, an unbound variable error + * is raised. + */ + final public LispObject getValue() throws ConditionThrowable + { + if (value == null) + return Lisp.error(new UnboundVariable(name)); + + return value; + } } 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 Thu Oct 22 16:25:36 2009 @@ -238,6 +238,7 @@ (defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;") (defconstant +lisp-environment-class+ "org/armedbear/lisp/Environment") (defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;") +(defconstant +lisp-special-binding-class+ "org/armedbear/lisp/SpecialBinding") (defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw") (defconstant +lisp-return-class+ "org/armedbear/lisp/Return") (defconstant +lisp-go-class+ "org/armedbear/lisp/Go") @@ -3939,6 +3940,7 @@ ;; Generates code to bind variable to value at top of runtime stack. (declaim (ftype (function (t) t) compile-binding)) (defun compile-binding (variable) +;; (dump-1-variable variable) (cond ((variable-register variable) (astore (variable-register variable))) ((variable-special-p variable) @@ -3947,7 +3949,11 @@ (emit-push-variable-name variable) (emit 'swap) (emit-invokevirtual +lisp-thread-class+ "bindSpecial" - (list +lisp-symbol+ +lisp-object+) nil)) + (list +lisp-symbol+ +lisp-object+) + +lisp-special-binding+) + (if (variable-binding-register variable) + (astore (variable-binding-register variable)) + (emit 'pop))) ((variable-closure-index variable) ;; stack: (emit-new-closure-binding variable)) (t @@ -4311,6 +4317,9 @@ (when (eq (variable-register variable) t) ;; Now allocate the register. (allocate-variable-register variable)) + (when (variable-special-p variable) + (setf (variable-binding-register variable) + (allocate-register))) (cond ((variable-special-p variable) (let ((temp-register (allocate-register))) ;; FIXME: this permanently allocates a register @@ -4358,7 +4367,10 @@ (emit-invokevirtual +lisp-thread-class+ "bindSpecialToCurrentValue" (list +lisp-symbol+) - nil) + +lisp-special-binding+) + (if (variable-binding-register variable) + (astore (variable-binding-register variable)) + (emit 'pop)) (setf boundp t)) ((and (not (variable-special-p variable)) (zerop (variable-reads variable))) @@ -4404,6 +4416,8 @@ (setf (variable-register variable) (allocate-register)))) (push variable *visible-variables*) (unless boundp + (when (variable-special-p variable) + (setf (variable-binding-register variable) (allocate-register))) (compile-binding variable)) (maybe-generate-type-check variable))) (when must-clear-values @@ -7354,30 +7368,42 @@ (t (compile-function-call form target representation))))) -(defun compile-special-reference (name target representation) - (when (constantp name) - (let ((value (symbol-value name))) - (when (or (null *file-compilation*) - (stringp value) - (numberp value) - (packagep value)) - (compile-constant value target representation) - (return-from compile-special-reference)))) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol name) - (emit 'getstatic class name +lisp-symbol+)) - (cond ((constantp name) - ;; "... a reference to a symbol declared with DEFCONSTANT always - ;; refers to its global value." - (emit-invokevirtual +lisp-symbol-class+ "getSymbolValue" - nil +lisp-object+)) - (t - (emit-push-current-thread) - (emit-invokevirtual +lisp-symbol-class+ "symbolValue" - (list +lisp-thread+) +lisp-object+))) - (fix-boxing representation nil) - (emit-move-from-stack target representation)) +(defun compile-special-reference (variable target representation) + (let ((name (variable-name variable))) + (when (constantp name) + (let ((value (symbol-value name))) + (when (or (null *file-compilation*) + (stringp value) + (numberp value) + (packagep value)) + (compile-constant value target representation) + (return-from compile-special-reference)))) + (unless (and (variable-binding-register variable) + (eq (variable-compiland variable) *current-compiland*) + (not (enclosed-by-runtime-bindings-creating-block-p + (variable-block variable)))) + (multiple-value-bind + (name class) + (lookup-or-declare-symbol name) + (emit 'getstatic class name +lisp-symbol+))) + (cond ((constantp name) + ;; "... a reference to a symbol declared with DEFCONSTANT always + ;; refers to its global value." + (emit-invokevirtual +lisp-symbol-class+ "getSymbolValue" + nil +lisp-object+)) + ((and (variable-binding-register variable) + (eq (variable-compiland variable) *current-compiland*) + (not (enclosed-by-runtime-bindings-creating-block-p + (variable-block variable)))) + (aload (variable-binding-register variable)) + (emit 'getfield +lisp-special-binding-class+ "value" + +lisp-object+)) + (t + (emit-push-current-thread) + (emit-invokevirtual +lisp-symbol-class+ "symbolValue" + (list +lisp-thread+) +lisp-object+))) + (fix-boxing representation nil) + (emit-move-from-stack target representation))) (defknown compile-var-ref (t t t) t) (defun compile-var-ref (ref target representation) @@ -7386,7 +7412,7 @@ (compile-constant (var-ref-constant-value ref) target representation) (let ((variable (var-ref-variable ref))) (cond ((variable-special-p variable) - (compile-special-reference (variable-name variable) target representation)) + (compile-special-reference variable target representation)) ((or (variable-representation variable) (variable-register variable) (variable-closure-index variable) @@ -7442,24 +7468,39 @@ (when (neq new-form form) (return-from p2-setq (compile-form (p1 new-form) target representation)))) ;; We're setting a special variable. - (emit-push-current-thread) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol name) - (emit 'getstatic class name +lisp-symbol+)) ;; (let ((*print-structure* nil)) ;; (format t "p2-setq name = ~S value-form = ~S~%" name value-form)) - (cond ((and (consp value-form) + (cond ((and variable + (variable-binding-register variable) + (eq (variable-compiland variable) *current-compiland*) + (not (enclosed-by-runtime-bindings-creating-block-p + (variable-block variable)))) + (aload (variable-binding-register variable)) + (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) + (emit 'dup_x1) ;; copy past th + (emit 'putfield +lisp-special-binding-class+ "value" + +lisp-object+)) + ((and (consp value-form) (eq (first value-form) 'CONS) (= (length value-form) 3) (var-ref-p (third value-form)) (eq (variable-name (var-ref-variable (third value-form))) name)) ;; (push thing *special*) => (setq *special* (cons thing *special*)) ;; (format t "compiling pushSpecial~%") + (emit-push-current-thread) + (multiple-value-bind + (name class) + (lookup-or-declare-symbol name) + (emit 'getstatic class name +lisp-symbol+)) (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) (emit-invokevirtual +lisp-thread-class+ "pushSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-object+)) (t + (emit-push-current-thread) + (multiple-value-bind + (name class) + (lookup-or-declare-symbol name) + (emit 'getstatic class name +lisp-symbol+)) (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+))) @@ -8281,6 +8322,7 @@ (label label-START) (dolist (variable (compiland-arg-vars compiland)) (when (variable-special-p variable) + (setf (variable-binding-register variable) (allocate-register)) (emit-push-current-thread) (emit-push-variable-name variable) (cond ((variable-register variable) @@ -8292,7 +8334,9 @@ (emit 'aaload) (setf (variable-index variable) nil))) (emit-invokevirtual +lisp-thread-class+ "bindSpecial" - (list +lisp-symbol+ +lisp-object+) nil)))) + (list +lisp-symbol+ +lisp-object+) + +lisp-special-binding+) + (astore (variable-binding-register variable))))) (compile-progn-body body 'stack) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Thu Oct 22 16:25:36 2009 @@ -247,10 +247,11 @@ (defvar *dump-variables* nil) (defun dump-1-variable (variable) - (sys::%format t " ~S special-p = ~S register = ~S index = ~S declared-type = ~S~%" + (sys::%format t " ~S special-p = ~S register = ~S binding-reg = ~S index = ~S declared-type = ~S~%" (variable-name variable) (variable-special-p variable) (variable-register variable) + (variable-binding-register variable) (variable-index variable) (variable-declared-type variable))) @@ -274,6 +275,7 @@ representation special-p ; indicates whether a variable is special register ; register number for a local variable + binding-register ; register number containing the binding reference index ; index number for a variable in the argument array closure-index ; index number for a variable in the closure context array environment ; the environment for the variable, if we're compiling in @@ -564,6 +566,21 @@ (catch-node-p object) (synchronized-node-p object))) +(defknown block-creates-runtime-bindings-p (t) boolean) +(defun block-creates-runtime-bindings-p (block) + ;; FIXME: This may be false, if the bindings to be + ;; created are a quoted list + (progv-node-p block)) + +(defknown enclosed-by-runtime-bindings-creating-block-p (t) boolean) +(defun enclosed-by-runtime-bindings-creating-block-p (outermost-block) + "Indicates whether the code being compiled/analyzed is enclosed in a +block which creates special bindings at runtime." + (dolist (enclosing-block *blocks*) + (when (eq enclosing-block outermost-block) + (return-from enclosed-by-runtime-bindings-creating-block-p nil)) + (when (block-creates-runtime-bindings-p enclosing-block) + (return-from enclosed-by-runtime-bindings-creating-block-p t)))) (defknown enclosed-by-protected-block-p (&optional t) boolean) (defun enclosed-by-protected-block-p (&optional outermost-block) From ehuelsmann at common-lisp.net Fri Oct 23 15:31:40 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 23 Oct 2009 11:31:40 -0400 Subject: [armedbear-cvs] r12211 - public_html/doc Message-ID: Author: ehuelsmann Date: Fri Oct 23 11:31:35 2009 New Revision: 12211 Log: Incorporate remark from John Pallister (prevent UNBOUND-VARIABLE error). Modified: public_html/doc/abcl-install-with-java.html Modified: public_html/doc/abcl-install-with-java.html ============================================================================== --- public_html/doc/abcl-install-with-java.html (original) +++ public_html/doc/abcl-install-with-java.html Fri Oct 23 11:31:35 2009 @@ -552,6 +552,8 @@ 

+(defvar symbols nil)
+
 (do-all-symbols (sym)
   (let ((package (symbol-package sym)))
        (cond



From ehuelsmann at common-lisp.net  Fri Oct 23 15:38:30 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 23 Oct 2009 11:38:30 -0400
Subject: [armedbear-cvs] r12212 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Fri Oct 23 11:38:30 2009
New Revision: 12212

Log:
Correct typo in (DEFINE-INT-BOUNDS-DERIVATION MIN ...).

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	Fri Oct 23 11:38:30 2009
@@ -6323,7 +6323,7 @@
 
 (define-int-bounds-derivation min (low1 high1 low2 high2)
   (values (or (when (and low1 low2) (min low1 low2)) low1 low2)
-          (or (when (and high1 high2) (min high1 high2)) high1 hig2)))
+          (or (when (and high1 high2) (min high1 high2)) high1 high2)))
 
 (defknown derive-type-min (t) t)
 (defun derive-type-min (form)



From ehuelsmann at common-lisp.net  Fri Oct 23 20:03:59 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 23 Oct 2009 16:03:59 -0400
Subject: [armedbear-cvs] r12213 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Fri Oct 23 16:03:55 2009
New Revision: 12213

Log:
Move the implementation of the Mutex functionality to the THREADS package
*and* move the implementation to Lisp.

Removed:
   trunk/abcl/src/org/armedbear/lisp/Mutex.java
   trunk/abcl/src/org/armedbear/lisp/with-mutex.lisp
Modified:
   trunk/abcl/src/org/armedbear/lisp/Autoload.java
   trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
   trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
   trunk/abcl/src/org/armedbear/lisp/threads.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java	Fri Oct 23 16:03:55 2009
@@ -665,10 +665,6 @@
         autoload(PACKAGE_SYS, "std-allocate-instance", "StandardObjectFunctions", true);
         autoload(PACKAGE_SYS, "zip", "zip", true);
 
-        autoload(PACKAGE_THREADS, "make-mutex", "Mutex", true);
-        autoload(PACKAGE_THREADS, "get-mutex", "Mutex", true);
-        autoload(PACKAGE_THREADS, "release-mutex", "Mutex", true);
-
         autoload(Symbol.COPY_LIST, "copy_list");
 
         autoload(Symbol.SET_CHAR, "StringFunctions");

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	Fri Oct 23 16:03:55 2009
@@ -292,20 +292,39 @@
 (autoload 'socket-peer-address "socket")
 
 (in-package "THREADS")
-(sys::export '(mailbox-send mailbox-empty-p mailbox-read mailbox-peek))
-(sys::autoload '(mailbox-send mailbox-empty-p mailbox-read mailbox-peek)
-    "threads")
 
-(sys::export '(make-thread-lock thread-lock thread-unlock with-thread-lock))
-(sys::autoload '(make-thread-lock thread-lock thread-unlock) "threads")
-(sys::autoload-macro 'with-thread-lock "threads")
 
-;; block to be removed at 0.22
+(autoload '(;; Mailbox
+            make-mailbox mailbox-send mailbox-empty-p
+            mailbox-read mailbox-peek
 
-(in-package "EXTENSIONS")
+            ;; Lock
+            make-thread-lock thread-lock thread-unlock
+
+            ;; Mutex
+            make-mutex get-mutex release-mutex)
+    "threads")
 
-(export '(mailbox-send mailbox-empty-p mailbox-read mailbox-peek))
+(autoload-macro '(;; Lock
+                  with-thread-lock
+
+                  ;; Mutex
+                  with-mutex)
+                "threads")
+
+(export '(make-mailbox mailbox-send mailbox-empty-p
+          mailbox-read mailbox-peek))
 (export '(make-thread-lock thread-lock thread-unlock with-thread-lock))
+(export '(make-mutex get-mutex release-mutex with-mutex))
+
+(progn
+  ;; block to be removed at 0.22
+  ;; It exists solely for pre-0.17 compatibility
+  ;; FIXME 0.22
+  (in-package "EXTENSIONS")
+  (export '(mailbox-send mailbox-empty-p mailbox-read mailbox-peek))
+  (export '(make-thread-lock thread-lock thread-unlock with-thread-lock))
+  (export '(with-mutex make-mutex get-mutex release-mutex)))
 
 ;; end of 0.22 block
 
@@ -340,6 +359,3 @@
 (export 'compiler-let)
 (autoload 'compiler-let)
 
-(in-package "THREADS")
-(export 'with-mutex)
-(ext:autoload-macro 'with-mutex)

Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp	Fri Oct 23 16:03:55 2009
@@ -256,7 +256,6 @@
                            "with-accessors.lisp"
                            "with-hash-table-iterator.lisp"
                            "with-input-from-string.lisp"
-                           "with-mutex.lisp"
                            "with-open-file.lisp"
                            "with-output-to-string.lisp"
                            "with-package-iterator.lisp"

Modified: trunk/abcl/src/org/armedbear/lisp/threads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/threads.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/threads.lisp	Fri Oct 23 16:03:55 2009
@@ -38,7 +38,7 @@
 ;;
 
 ;; this export statement is also in autoloads.lisp
-(export '(mailbox-send mailbox-empty-p mailbox-read mailbox-peek))
+(export '(make-mailbox mailbox-send mailbox-empty-p mailbox-read mailbox-peek))
 
 (defstruct mailbox
   queue)
@@ -82,6 +82,43 @@
 
 
 ;;
+;; Mutex implementation
+;;
+
+
+;; this export statement is also in autoloads.lisp
+(export '(make-mutex get-mutex release-mutex))
+
+(defstruct mutex
+  in-use)
+
+(defun get-mutex (mutex)
+  "Acquires a lock on the `mutex'."
+  (synchronized-on mutex
+    (loop
+       while (mutex-in-use mutex)
+       do (object-wait mutex))
+    (setf (mutex-in-use mutex) T)))
+
+(defun release-mutex (mutex)
+  "Releases a lock on the `mutex'."
+  (synchronized-on mutex
+    (setf (mutex-in-use mutex) NIL)
+    (object-notify mutex)))
+
+(defmacro with-mutex ((mutex) &body body)
+  "Acquires a lock on `mutex', executes the body
+and releases the lock."
+  (let ((m (gensym)))
+    `(let ((,m ,mutex))
+       (when (get-mutex ,m)
+         (unwind-protect
+          (progn
+            , at body)
+          (release-mutex ,m))))))
+
+
+;;
 ;; Lock implementation
 ;;
 
@@ -90,6 +127,7 @@
   (gensym))
 
 (defmacro with-thread-lock ((lock) &body body)
+  "Acquires a lock on the `lock', executes `body' and releases the lock."
   (let ((glock (gensym)))
     `(let ((,glock ,lock))
        (synchronized-on ,glock



From ehuelsmann at common-lisp.net  Fri Oct 23 20:14:24 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 23 Oct 2009 16:14:24 -0400
Subject: [armedbear-cvs] r12214 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Fri Oct 23 16:14:23 2009
New Revision: 12214

Log:
Fix braekage from last commit.


Modified:
   trunk/abcl/src/org/armedbear/lisp/Lisp.java

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	Fri Oct 23 16:14:23 2009
@@ -120,6 +120,8 @@
         PACKAGE_LISP.usePackage(PACKAGE_EXT);
         PACKAGE_LISP.usePackage(PACKAGE_SYS);
         PACKAGE_THREADS.usePackage(PACKAGE_CL);
+        PACKAGE_THREADS.usePackage(PACKAGE_EXT);
+        PACKAGE_THREADS.usePackage(PACKAGE_SYS);
       }
     catch (Throwable t)
       {



From ehuelsmann at common-lisp.net  Fri Oct 23 20:45:16 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 23 Oct 2009 16:45:16 -0400
Subject: [armedbear-cvs] r12215 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Fri Oct 23 16:45:15 2009
New Revision: 12215

Log:
Add description of the purpose of the autoloads.lisp file.

Requested by: Tobias Rittweiler

Modified:
   trunk/abcl/src/org/armedbear/lisp/autoloads.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	Fri Oct 23 16:45:15 2009
@@ -29,6 +29,23 @@
 ;;; obligated to do so.  If you do not wish to do so, delete this
 ;;; exception statement from your version.
 
+
+;; This file lists public functions which package users can depend upon.
+;;
+;; In order to avoid loading the full CL system (of which not all functions
+;; may be required by the current program), this file makes sure the symbols
+;; are available, but when it tries to execute them, the autoloader causes
+;; the actual functions or macros to be loaded.
+
+;; This file lists for each autoloaded symbol which file has to be
+;; REQUIRE'd to make it available.
+;;
+;; Please note: the actual function definition may not be always in the
+;;    same file as the one which needs to be REQUIRE'd; an example of
+;;    such a case is the compiler: all compiler functions have to be
+;;    loaded through loading jvm.lisp.
+
+
 (in-package "SYSTEM")
 
 (autoload '(char/= char> char>= char-not-equal)



From ehuelsmann at common-lisp.net  Fri Oct 23 21:33:43 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 23 Oct 2009 17:33:43 -0400
Subject: [armedbear-cvs] r12216 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Fri Oct 23 17:33:42 2009
New Revision: 12216

Log:
Make sure the #n= and #n# reader functionality gets compiled.

It's unacceptable to have uncompiled functions processing potentially
huge amounts of data.

Added:
   trunk/abcl/src/org/armedbear/lisp/read-circle.lisp
Modified:
   trunk/abcl/src/org/armedbear/lisp/boot.lisp
   trunk/abcl/src/org/armedbear/lisp/compile-system.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/boot.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/boot.lisp	Fri Oct 23 17:33:42 2009
@@ -145,144 +145,7 @@
 (defun make-package (package-name &key nicknames use)
   (%make-package package-name nicknames use))
 
-;;; Reading circular data: the #= and ## reader macros (from SBCL)
-
-;;; Objects already seen by CIRCLE-SUBST.
-(defvar *sharp-equal-circle-table*)
-
-;; This function is kind of like NSUBLIS, but checks for circularities and
-;; substitutes in arrays and structures as well as lists. The first arg is an
-;; alist of the things to be replaced assoc'd with the things to replace them.
-(defun circle-subst (old-new-alist tree)
-  (macrolet ((recursable-element-p (subtree)
-                `(typep ,subtree
-                       '(or cons (array t) structure-object standard-object)))
-             (element-replacement (subtree)
-               `(let ((entry (find ,subtree old-new-alist :key #'second)))
-                  (if entry (third entry) ,subtree))))
-  (cond ((not (recursable-element-p tree))
-         (element-replacement tree))
-        ((null (gethash tree *sharp-equal-circle-table*))
-         (cond
-          ((typep tree 'structure-object)
-           (setf (gethash tree *sharp-equal-circle-table*) t)
-           (do ((i 0 (1+ i))
-                (end (structure-length tree)))
-               ((= i end))
-             (let* ((old (structure-ref tree i))
-                    (new (circle-subst old-new-alist old)))
-               (unless (eq old new)
-                 (structure-set tree i new)))))
-;;           ((typep tree 'standard-object)
-;;            (setf (gethash tree *sharp-equal-circle-table*) t)
-;;            (do ((i 1 (1+ i))
-;;                 (end (%instance-length tree)))
-;;                ((= i end))
-;;              (let* ((old (%instance-ref tree i))
-;;                     (new (circle-subst old-new-alist old)))
-;;                (unless (eq old new)
-;;                  (setf (%instance-ref tree i) new)))))
-          ((arrayp tree)
-           (setf (gethash tree *sharp-equal-circle-table*) t)
-           (do ((i 0 (1+ i))
-                (end (array-total-size tree)))
-               ((>= i end))
-             (let* ((old (row-major-aref tree i))
-                    (new (circle-subst old-new-alist old)))
-               (unless (eq old new)
-                 (setf (row-major-aref tree i) new)))))
-         (t ;; being CONSP as all the other cases have been handled
-            (do ((subtree tree (cdr subtree)))
-                ((or (not (consp subtree))
-                     (gethash subtree *sharp-equal-circle-table*)))
-                ;; CDR no longer a CONS; no need to recurse any further:
-                ;; the case where the CDR is a symbol to be replaced
-                ;; has been handled in the last iteration
-              (setf (gethash subtree *sharp-equal-circle-table*) t)
-              (let* ((c (car subtree))
-                     (d (cdr subtree))
-                     (a (if (recursable-element-p c)
-                            (circle-subst old-new-alist c)
-                            (element-replacement c)))
-                     (b (cond
-                         ((consp d) d) ;; CONSes handled in the loop
-                         ((recursable-element-p d)
-                          ;; ARRAY, STRUCTURE-OBJECT and STANDARD-OBJECT
-                          ;; handled in recursive calls
-                          (circle-subst old-new-alist d))
-                         (t
-                          (element-replacement d)))))
-                (unless (eq a c)
-                  (rplaca subtree a))
-                (unless (eq d b)
-                  (rplacd subtree b))))))
-        tree)
-  (t tree))))
-
-;;; Sharp-equal works as follows. When a label is assigned (i.e. when
-;;; #= is called) we GENSYM a symbol is which is used as an
-;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
-;;; gensym.
-;;;
-;;; When SHARP-SHARP encounters a reference to a label, it returns the
-;;; symbol assoc'd with the label. Resolution of the reference is
-;;; deferred until the read done by #= finishes. Any already resolved
-;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
-;;;
-;;; After reading of the #= form is completed, we add an entry to
-;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
-;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
-;;; object is searched and any uses of the gensysm token are replaced
-;;; with the actual value.
-
-(defvar *sharp-sharp-alist* ())
-
-(defun sharp-equal (stream ignore label)
-  (declare (ignore ignore))
-  (when *read-suppress* (return-from sharp-equal (values)))
-  (unless label
-    (error 'reader-error
-           :stream stream
-           :format-control "Missing label for #="))
-  (when (or (assoc label *sharp-sharp-alist*)
-            (assoc label *sharp-equal-alist*))
-    (error 'reader-error
-           :stream stream
-           :format-control "Multiply defined label: #~D="
-           :format-arguments (list label)))
-  (let* ((tag (gensym))
-         (*sharp-sharp-alist* (cons (list label tag nil) *sharp-sharp-alist*))
-         (obj (read stream t nil t)))
-    (when (eq obj tag)
-      (error 'reader-error
-             :stream stream
-             :format-control "Must tag something more than just #~D#"
-             :format-arguments (list label)))
-    (push (list label tag obj) *sharp-equal-alist*)
-    (when (third (car *sharp-sharp-alist*)) ;; set to T on circularity
-      (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
-        (circle-subst *sharp-equal-alist* obj)))
-    obj))
-
-(defun sharp-sharp (stream ignore label)
-  (declare (ignore ignore))
-  (when *read-suppress* (return-from sharp-sharp nil))
-  (unless label
-    (error 'reader-error :stream stream :format-control "Missing label for ##"))
-  (let ((entry (assoc label *sharp-equal-alist*)))
-    (if entry
-        (third entry)
-        (let ((pair (assoc label *sharp-sharp-alist*)))
-          (unless pair
-            (error 'reader-error
-                   :stream stream
-                   :format-control "Object is not labelled #~S#"
-                   :format-arguments (list label)))
-          (setf (third pair) t)
-          (second pair)))))
-
-(set-dispatch-macro-character #\# #\= #'sharp-equal +standard-readtable+)
-(set-dispatch-macro-character #\# #\# #'sharp-sharp +standard-readtable+)
+(load-system-file "read-circle")
 
 (copy-readtable +standard-readtable+ *readtable*)
 

Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp	Fri Oct 23 17:33:42 2009
@@ -220,6 +220,7 @@
                            "prog.lisp"
                            "psetf.lisp"
                            "query.lisp"
+                           "read-circle.lisp"
                            "read-conditional.lisp"
                            "read-from-string.lisp"
                            "read-sequence.lisp"

Added: trunk/abcl/src/org/armedbear/lisp/read-circle.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/read-circle.lisp	Fri Oct 23 17:33:42 2009
@@ -0,0 +1,173 @@
+;;; read-circle.lisp
+;;;
+;;; Copyright (C) 2009 Erik Huelsmann
+;;; $Id: read-conditional.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
+;;;
+;;; 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.
+;;;
+;;; 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 "SYSTEM")
+
+
+;;; Reading circular data: the #= and ## reader macros (from SBCL)
+
+;;; Objects already seen by CIRCLE-SUBST.
+(defvar *sharp-equal-circle-table*)
+
+;; This function is kind of like NSUBLIS, but checks for circularities and
+;; substitutes in arrays and structures as well as lists. The first arg is an
+;; alist of the things to be replaced assoc'd with the things to replace them.
+(defun circle-subst (old-new-alist tree)
+  (macrolet ((recursable-element-p (subtree)
+                `(typep ,subtree
+                       '(or cons (array t) structure-object standard-object)))
+             (element-replacement (subtree)
+               `(let ((entry (find ,subtree old-new-alist :key #'second)))
+                  (if entry (third entry) ,subtree))))
+  (cond ((not (recursable-element-p tree))
+         (element-replacement tree))
+        ((null (gethash tree *sharp-equal-circle-table*))
+         (cond
+          ((typep tree 'structure-object)
+           (setf (gethash tree *sharp-equal-circle-table*) t)
+           (do ((i 0 (1+ i))
+                (end (structure-length tree)))
+               ((= i end))
+             (let* ((old (structure-ref tree i))
+                    (new (circle-subst old-new-alist old)))
+               (unless (eq old new)
+                 (structure-set tree i new)))))
+;;           ((typep tree 'standard-object)
+;;            (setf (gethash tree *sharp-equal-circle-table*) t)
+;;            (do ((i 1 (1+ i))
+;;                 (end (%instance-length tree)))
+;;                ((= i end))
+;;              (let* ((old (%instance-ref tree i))
+;;                     (new (circle-subst old-new-alist old)))
+;;                (unless (eq old new)
+;;                  (setf (%instance-ref tree i) new)))))
+          ((arrayp tree)
+           (setf (gethash tree *sharp-equal-circle-table*) t)
+           (do ((i 0 (1+ i))
+                (end (array-total-size tree)))
+               ((>= i end))
+             (let* ((old (row-major-aref tree i))
+                    (new (circle-subst old-new-alist old)))
+               (unless (eq old new)
+                 (setf (row-major-aref tree i) new)))))
+         (t ;; being CONSP as all the other cases have been handled
+            (do ((subtree tree (cdr subtree)))
+                ((or (not (consp subtree))
+                     (gethash subtree *sharp-equal-circle-table*)))
+                ;; CDR no longer a CONS; no need to recurse any further:
+                ;; the case where the CDR is a symbol to be replaced
+                ;; has been handled in the last iteration
+              (setf (gethash subtree *sharp-equal-circle-table*) t)
+              (let* ((c (car subtree))
+                     (d (cdr subtree))
+                     (a (if (recursable-element-p c)
+                            (circle-subst old-new-alist c)
+                            (element-replacement c)))
+                     (b (cond
+                         ((consp d) d) ;; CONSes handled in the loop
+                         ((recursable-element-p d)
+                          ;; ARRAY, STRUCTURE-OBJECT and STANDARD-OBJECT
+                          ;; handled in recursive calls
+                          (circle-subst old-new-alist d))
+                         (t
+                          (element-replacement d)))))
+                (unless (eq a c)
+                  (rplaca subtree a))
+                (unless (eq d b)
+                  (rplacd subtree b))))))
+        tree)
+  (t tree))))
+
+;;; Sharp-equal works as follows. When a label is assigned (i.e. when
+;;; #= is called) we GENSYM a symbol is which is used as an
+;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
+;;; gensym.
+;;;
+;;; When SHARP-SHARP encounters a reference to a label, it returns the
+;;; symbol assoc'd with the label. Resolution of the reference is
+;;; deferred until the read done by #= finishes. Any already resolved
+;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
+;;;
+;;; After reading of the #= form is completed, we add an entry to
+;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
+;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
+;;; object is searched and any uses of the gensysm token are replaced
+;;; with the actual value.
+
+(defvar *sharp-sharp-alist* ())
+
+(defun sharp-equal (stream ignore label)
+  (declare (ignore ignore))
+  (when *read-suppress* (return-from sharp-equal (values)))
+  (unless label
+    (error 'reader-error
+           :stream stream
+           :format-control "Missing label for #="))
+  (when (or (assoc label *sharp-sharp-alist*)
+            (assoc label *sharp-equal-alist*))
+    (error 'reader-error
+           :stream stream
+           :format-control "Multiply defined label: #~D="
+           :format-arguments (list label)))
+  (let* ((tag (gensym))
+         (*sharp-sharp-alist* (cons (list label tag nil) *sharp-sharp-alist*))
+         (obj (read stream t nil t)))
+    (when (eq obj tag)
+      (error 'reader-error
+             :stream stream
+             :format-control "Must tag something more than just #~D#"
+             :format-arguments (list label)))
+    (push (list label tag obj) *sharp-equal-alist*)
+    (when (third (car *sharp-sharp-alist*)) ;; set to T on circularity
+      (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
+        (circle-subst *sharp-equal-alist* obj)))
+    obj))
+
+(defun sharp-sharp (stream ignore label)
+  (declare (ignore ignore))
+  (when *read-suppress* (return-from sharp-sharp nil))
+  (unless label
+    (error 'reader-error :stream stream :format-control "Missing label for ##"))
+  (let ((entry (assoc label *sharp-equal-alist*)))
+    (if entry
+        (third entry)
+        (let ((pair (assoc label *sharp-sharp-alist*)))
+          (unless pair
+            (error 'reader-error
+                   :stream stream
+                   :format-control "Object is not labelled #~S#"
+                   :format-arguments (list label)))
+          (setf (third pair) t)
+          (second pair)))))
+
+(set-dispatch-macro-character #\# #\= #'sharp-equal +standard-readtable+)
+(set-dispatch-macro-character #\# #\# #'sharp-sharp +standard-readtable+)
+



From ehuelsmann at common-lisp.net  Fri Oct 23 21:34:40 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 23 Oct 2009 17:34:40 -0400
Subject: [armedbear-cvs] r12217 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Fri Oct 23 17:34:37 2009
New Revision: 12217

Log:
Clean up use of RESOLVE (remove unnecessary case and replace one with REQUIRE).

Modified:
   trunk/abcl/src/org/armedbear/lisp/apropos.lisp
   trunk/abcl/src/org/armedbear/lisp/remove.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/apropos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/apropos.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/apropos.lisp	Fri Oct 23 17:34:37 2009
@@ -33,7 +33,6 @@
 
 (in-package #:system)
 
-(resolve 'write-string)
 
 (defun apropos-list (string-designator &optional package-designator)
   (if package-designator

Modified: trunk/abcl/src/org/armedbear/lisp/remove.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/remove.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/remove.lisp	Fri Oct 23 17:34:37 2009
@@ -31,7 +31,7 @@
 
 (in-package "SYSTEM")
 
-(resolve 'delete) ; MUMBLE-DELETE-FROM-END
+(require "DELETE") ; MUMBLE-DELETE-FROM-END
 
 ;;; From CMUCL.
 



From ehuelsmann at common-lisp.net  Fri Oct 23 21:59:15 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 23 Oct 2009 17:59:15 -0400
Subject: [armedbear-cvs] r12218 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Fri Oct 23 17:59:14 2009
New Revision: 12218

Log:
Centralize package creation (in Lisp.java).

This moves the creation of the XP and FORMAT packages away from boot.lisp.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Lisp.java
   trunk/abcl/src/org/armedbear/lisp/boot.lisp
   trunk/abcl/src/org/armedbear/lisp/print.lisp

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	Fri Oct 23 17:59:14 2009
@@ -81,6 +81,11 @@
     Packages.createPackage("LISP");
   public static final Package PACKAGE_THREADS =
     Packages.createPackage("THREADS");
+  public static final Package PACKAGE_FORMAT =
+    Packages.createPackage("FORMAT");
+  public static final Package PACKAGE_XP =
+    Packages.createPackage("XP");
+
 
   // ### nil
   public static final LispObject NIL = Nil.NIL;
@@ -122,6 +127,9 @@
         PACKAGE_THREADS.usePackage(PACKAGE_CL);
         PACKAGE_THREADS.usePackage(PACKAGE_EXT);
         PACKAGE_THREADS.usePackage(PACKAGE_SYS);
+        PACKAGE_FORMAT.usePackage(PACKAGE_CL);
+        PACKAGE_FORMAT.usePackage(PACKAGE_EXT);
+        PACKAGE_XP.usePackage(PACKAGE_CL);
       }
     catch (Throwable t)
       {
@@ -2777,6 +2785,7 @@
     loadClass("org.armedbear.lisp.StructureObject");
     loadClass("org.armedbear.lisp.ash");
     loadClass("org.armedbear.lisp.Java");
+    loadClass("org.armedbear.lisp.PackageFunctions");
     cold = false;
   }
 }

Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/boot.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/boot.lisp	Fri Oct 23 17:59:14 2009
@@ -175,14 +175,6 @@
 (load-system-file "defpackage")
 (load-system-file "define-modify-macro")
 
-;;; Package definitions.
-(defpackage "FORMAT" (:use "CL" "EXT"))
-
-(defpackage "XP"
-  (:use "CL")
-  (:export
-   #:output-pretty-object))
-
 (defconstant lambda-list-keywords
   '(&optional &rest &key &aux &body &whole &allow-other-keys &environment))
 

Modified: trunk/abcl/src/org/armedbear/lisp/print.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/print.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/print.lisp	Fri Oct 23 17:59:14 2009
@@ -273,7 +273,7 @@
 
 (defun %print-object (object stream)
   (if *print-pretty*
-      (xp:output-pretty-object object stream)
+      (xp::output-pretty-object object stream)
       (output-ugly-object object stream)))
 
 (defun %check-object (object stream)



From ehuelsmann at common-lisp.net  Fri Oct 23 23:07:15 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 23 Oct 2009 19:07:15 -0400
Subject: [armedbear-cvs] r12219 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Fri Oct 23 19:07:12 2009
New Revision: 12219

Log:
Remove package precompilation in boot.lisp; since we
  compile 99.9% of all functions, precompilation doesn't buy us anything,
  yet it costs us startup time (not measurable).

Modified:
   trunk/abcl/src/org/armedbear/lisp/boot.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/boot.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/boot.lisp	Fri Oct 23 19:07:12 2009
@@ -162,12 +162,6 @@
 (load-system-file "compiler-error")
 (load-system-file "source-transform")
 (load-system-file "precompiler")
-
-(precompile-package "PRECOMPILER")
-(precompile-package "EXTENSIONS")
-(precompile-package "SYSTEM")
-(precompile-package "COMMON-LISP")
-
 (load-system-file "signal")
 (load-system-file "list")
 (load-system-file "sequences")



From ehuelsmann at common-lisp.net  Sat Oct 24 10:55:59 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 24 Oct 2009 06:55:59 -0400
Subject: [armedbear-cvs] r12220 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Sat Oct 24 06:55:56 2009
New Revision: 12220

Log:
In addition to "simple" function calls, don't make compiled
 cls files for single SETQ statements with a "simple"
 value argument.

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	Sat Oct 24 06:55:56 2009
@@ -370,16 +370,25 @@
                    ;; FIXME This should be a warning or error of some sort...
                    (format *error-output* "; Unable to compile method~%")))))))))
 
+(declaim (ftype (function (t) t) simple-toplevel-form-p))
+(defun simple-toplevel-form-p (form)
+  "Returns NIL if the form is too complex to become an
+interpreted toplevel form, non-NIL if it is 'simple enough'."
+  (and (consp form)
+       (every #'(lambda (arg)
+                  (or (and (atom arg)
+                           (not (and (symbolp arg)
+                                     (symbol-macro-p arg))))
+                      (and (consp arg)
+                           (eq 'QUOTE (car arg)))))
+              (cdr form))))
+
 (declaim (ftype (function (t) t) convert-toplevel-form))
 (defun convert-toplevel-form (form)
-  (when (and (consp form)
-             (every #'(lambda (arg)
-                        (or (and (atom arg)
-                                 (not (and (symbolp arg)
-                                           (symbol-macro-p arg))))
-                            (and (consp arg)
-                                 (eq 'QUOTE (car arg)))))
-                    (cdr form)))
+  (when (or (simple-toplevel-form-p form)
+            (and (eq (car form) 'SETQ)
+                 ;; for SETQ, look at the evaluated part
+                 (simple-toplevel-form-p (third form))))
     ;; single form with simple or constant arguments
     ;; Without this exception, toplevel function calls
     ;; will be compiled into lambdas which get compiled to



From ehuelsmann at common-lisp.net  Sun Oct 25 19:56:44 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 25 Oct 2009 15:56:44 -0400
Subject: [armedbear-cvs] r12221 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Sun Oct 25 15:56:41 2009
New Revision: 12221

Log:
In case a built-in error object (Condition class derivative) is
passed as an argument to the ERROR stub, print its message (for
easier debugging).

Modified:
   trunk/abcl/src/org/armedbear/lisp/Primitives.java

Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java	Sun Oct 25 15:56:41 2009
@@ -1462,8 +1462,14 @@
         e.printStackTrace();
 
         System.out.println("ERROR placeholder called with arguments:");
-        for (LispObject a : args)
-            System.out.println(a.writeToString());
+
+        if (args.length == 1 && args[0] instanceof Condition) {
+            System.out.println(args[0].writeToString());
+            System.out.println(((Condition)args[0]).getConditionReport());
+        }
+        else
+            for (LispObject a : args)
+                System.out.println(a.writeToString());
 
         //###FIXME: Bail out, but do it nicer...
         System.exit(1);



From ehuelsmann at common-lisp.net  Sun Oct 25 20:18:07 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 25 Oct 2009 16:18:07 -0400
Subject: [armedbear-cvs] r12222 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Sun Oct 25 16:18:05 2009
New Revision: 12222

Log:
Centralize package creation for consistency:
 Create PRECOMPILER with the other packages.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Lisp.java
   trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java	Sun Oct 25 16:18:05 2009
@@ -85,6 +85,8 @@
     Packages.createPackage("FORMAT");
   public static final Package PACKAGE_XP =
     Packages.createPackage("XP");
+  public static final Package PACKAGE_PRECOMPILER =
+    Packages.createPackage("PRECOMPILER");
 
 
   // ### nil
@@ -130,6 +132,10 @@
         PACKAGE_FORMAT.usePackage(PACKAGE_CL);
         PACKAGE_FORMAT.usePackage(PACKAGE_EXT);
         PACKAGE_XP.usePackage(PACKAGE_CL);
+        PACKAGE_PRECOMPILER.addNickname("PRE");
+        PACKAGE_PRECOMPILER.usePackage(PACKAGE_CL);
+        PACKAGE_PRECOMPILER.usePackage(PACKAGE_EXT);
+        PACKAGE_PRECOMPILER.usePackage(PACKAGE_SYS);
       }
     catch (Throwable t)
       {

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 Oct 25 16:18:05 2009
@@ -331,12 +331,6 @@
         (t
          form)))
 
-(in-package "EXTENSIONS")
-
-(unless (find-package "PRECOMPILER")
-  (make-package "PRECOMPILER"
-                :nicknames '("PRE")
-                :use '("COMMON-LISP" "EXTENSIONS" "SYSTEM")))
 
 (in-package "PRECOMPILER")
 



From ehuelsmann at common-lisp.net  Sun Oct 25 22:27:47 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 25 Oct 2009 18:27:47 -0400
Subject: [armedbear-cvs] r12223 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Sun Oct 25 18:27:44 2009
New Revision: 12223

Log:
The Lisp class turns out to contain some static symbols too,
  use them, when they are being referred to.

Modified:
   trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp	Sun Oct 25 18:27:44 2009
@@ -50,6 +50,7 @@
 
   (initialize-known-symbols "org.armedbear.lisp.Symbol" symbols)
   (initialize-known-symbols "org.armedbear.lisp.Keyword" symbols)
+  (initialize-known-symbols "org.armedbear.lisp.Lisp" symbols)
 
   (defun lookup-known-symbol (symbol)
     "Returns the name of the field and its class designator



From ehuelsmann at common-lisp.net  Sun Oct 25 22:29:08 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 25 Oct 2009 18:29:08 -0400
Subject: [armedbear-cvs] r12224 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Sun Oct 25 18:29:07 2009
New Revision: 12224

Log:
Make it possible to require a double-colon package separator
 by setting *DOUBLE-COLON-PACKAGE-SEPARATORS* to non-NIL.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Lisp.java
   trunk/abcl/src/org/armedbear/lisp/Symbol.java

Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java	Sun Oct 25 18:29:07 2009
@@ -2450,6 +2450,11 @@
     Symbol.COMPILE_FILE_TRUENAME.initializeSpecial(NIL);
   }
 
+  // ### *double-colon-package-separators*
+  // internal symbol
+  public static final Symbol DOUBLE_COLON_PACKAGE_SEPARATORS =
+    internSpecial("*DOUBLE-COLON-PACKAGE-SEPARATORS*", PACKAGE_SYS, NIL);
+
   // ### *load-depth*
   // internal symbol
   public static final Symbol _LOAD_DEPTH_ =

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	Sun Oct 25 18:29:07 2009
@@ -580,7 +580,8 @@
           }
       }
     FastStringBuffer sb = new FastStringBuffer(packageName);
-    if (((Package)pkg).findExternalSymbol(name) != null)
+    if (((Package)pkg).findExternalSymbol(name) != null
+        && DOUBLE_COLON_PACKAGE_SEPARATORS.symbolValue(thread) == NIL)
       sb.append(':');
     else
       sb.append("::");



From ehuelsmann at common-lisp.net  Sun Oct 25 22:30:16 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 25 Oct 2009 18:30:16 -0400
Subject: [armedbear-cvs] r12225 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Sun Oct 25 18:30:15 2009
New Revision: 12225

Log:
Print autoloading information if the property "abcl.autoload.verbose" is set to "Y".

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

Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java	Sun Oct 25 18:30:15 2009
@@ -106,7 +106,9 @@
             int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue());
             thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth));
             try {
-                if (_AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL) {
+                if (_AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL
+                    || "Y".equals(System.getProperty("abcl.autoload.verbose")))
+                {
                     final String prefix = Load.getLoadVerbosePrefix(loadDepth);
                     Stream out = getStandardOutput();
                     out._writeString(prefix);



From ehuelsmann at common-lisp.net  Sun Oct 25 22:35:53 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 25 Oct 2009 18:35:53 -0400
Subject: [armedbear-cvs] r12226 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Sun Oct 25 18:35:52 2009
New Revision: 12226

Log:
Binary FASL support.
  compile-file.lisp: Catch forms for output and compile them.
  compiler-pass2.lisp: Allow fields to be declared in-line
    which means they are part of the evaluation of the compiled function,
    instead of in its constructor - where constants will still be constructed.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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	Sun Oct 25 18:35:52 2009
@@ -76,8 +76,8 @@
   (declare (ignore classfile))
   t)
 
-(declaim (ftype (function (t stream) t) process-defconstant))
-(defun process-defconstant (form stream)
+(declaim (ftype (function (t) t) process-defconstant))
+(defun process-defconstant (form)
   ;; "If a DEFCONSTANT form appears as a top level form, the compiler
   ;; must recognize that [the] name names a constant variable. An
   ;; implementation may choose to evaluate the value-form at compile
@@ -86,8 +86,7 @@
   ;; whether or not references to name appear in the file) and that
   ;; it always evaluates to the same value."
   (eval form)
-  (dump-form form stream)
-  (%stream-terpri stream))
+  (output-form form))
 
 (declaim (ftype (function (t) t) note-toplevel-form))
 (defun note-toplevel-form (form)
@@ -117,8 +116,7 @@
            (eval form)
            ;; Force package prefix to be used when dumping form.
            (let ((*package* +keyword-package+))
-             (dump-form form stream))
-           (%stream-terpri stream)
+             (output-form form))
            (return-from process-toplevel-form))
           ((DEFVAR DEFPARAMETER)
            (note-toplevel-form form)
@@ -133,7 +131,7 @@
                  (%defvar name))))
           (DEFCONSTANT
            (note-toplevel-form form)
-           (process-defconstant form stream)
+           (process-defconstant form)
            (return-from process-toplevel-form))
           (DEFUN
            (note-toplevel-form form)
@@ -154,7 +152,7 @@
 				       :if-exists :supersede)
 				  (report-error
 				   (jvm:compile-defun name expr nil
-						      classfile f))))
+						      classfile f nil))))
                         (compiled-function (verify-load classfile)))
 		   (declare (ignore result))
                    (cond
@@ -187,10 +185,8 @@
                    (setf (inline-expansion name)
                          (jvm::generate-inline-expansion block-name
                                                          lambda-list body))
-                   (dump-form `(setf (inline-expansion ',name)
-                                     ',(inline-expansion name))
-                              stream)
-                   (%stream-terpri stream))))
+                   (output-form `(setf (inline-expansion ',name)
+                                       ',(inline-expansion name))))))
              (push name jvm::*functions-defined-in-current-file*)
              (note-name-defined name)
              ;; If NAME is not fbound, provide a dummy definition so that
@@ -218,7 +214,7 @@
 		      :element-type '(unsigned-byte 8)
 		      :if-exists :supersede)
 		 (ignore-errors
-		   (jvm:compile-defun nil expr nil classfile f)))
+		   (jvm:compile-defun nil expr nil classfile f nil)))
                (if (null (verify-load classfile))
                    ;; FIXME error or warning
                    (format *error-output* "; Unable to compile macro ~A~%" name)
@@ -299,8 +295,7 @@
                   (setf form (precompiler:precompile-form form nil *compile-file-environment*))
                   ;; Make sure package prefix is printed when symbols are imported.
                   (let ((*package* +keyword-package+))
-                    (dump-form form stream))
-                  (%stream-terpri stream)
+                    (output-form form))
                   (when compile-time-too
                     (eval form))
                   (return-from process-toplevel-form))
@@ -326,10 +321,9 @@
                  (t
 ;;;                      (setf form (precompiler:precompile-form form nil))
                   (note-toplevel-form form)
-                  (setf form (convert-toplevel-form form)))))))))
+                  (setf form (convert-toplevel-form form nil)))))))))
   (when (consp form)
-    (dump-form form stream)
-    (%stream-terpri stream))
+    (output-form form))
   ;; Make sure the compiled-function loader knows where
   ;; to load the compiled functions. Note that this trickery
   ;; was already used in verify-load before I used it,
@@ -360,7 +354,7 @@
 			 :element-type '(unsigned-byte 8)
 			 :if-exists :supersede)
 		    (report-error
-		     (jvm:compile-defun nil lambda-expression nil classfile f))))
+		     (jvm:compile-defun nil lambda-expression nil classfile f nil))))
                  (compiled-function (verify-load classfile)))
 	    (declare (ignore result))
             (cond (compiled-function
@@ -375,12 +369,12 @@
   "Returns NIL if the form is too complex to become an
 interpreted toplevel form, non-NIL if it is 'simple enough'."
   (and (consp form)
-       (every #'(lambda (arg)
-                  (or (and (atom arg)
-                           (not (and (symbolp arg)
-                                     (symbol-macro-p arg))))
-                      (and (consp arg)
-                           (eq 'QUOTE (car arg)))))
+             (every #'(lambda (arg)
+                        (or (and (atom arg)
+                                 (not (and (symbolp arg)
+                                           (symbol-macro-p arg))))
+                            (and (consp arg)
+                                 (eq 'QUOTE (car arg)))))
               (cdr form))))
 
 (declaim (ftype (function (t) t) convert-toplevel-form))
@@ -405,7 +399,8 @@
 		 :direction :output
 		 :element-type '(unsigned-byte 8)
 		 :if-exists :supersede)
-	    (report-error (jvm:compile-defun nil expr nil classfile f))))
+	    (report-error (jvm:compile-defun nil expr nil classfile
+                                             f declare-inline))))
          (compiled-function (verify-load classfile)))
     (declare (ignore result))
     (setf form
@@ -447,13 +442,35 @@
 	  (intersection '(:load-toplevel load) situations)
 	  (intersection '(:execute eval) situations)))
 
+
+(defvar *binary-fasls* nil)
+(defvar *forms-for-output* nil)
+(defvar *fasl-stream* nil)
+
+(defun output-form (form)
+  (if *binary-fasls*
+      (push form *forms-for-output*)
+      (progn
+        (dump-form form *fasl-stream*)
+        (%stream-terpri *fasl-stream*))))
+
+(defun finalize-fasl-output ()
+  (when *binary-fasls*
+    (let ((*package* (find-package :keyword))
+          (*double-colon-package-separators* T))
+      (dump-form (convert-toplevel-form (list* 'PROGN
+                                               (nreverse *forms-for-output*))
+                                        t)
+                 *fasl-stream*))
+    (%stream-terpri *fasl-stream*)))
+
 (defun compile-file (input-file
                      &key
                      output-file
                      ((:verbose *compile-verbose*) *compile-verbose*)
                      ((:print *compile-print*) *compile-print*)
                      external-format)
-  (declare (ignore external-format)) ; FIXME
+  (declare (ignore external-format))    ; FIXME
   (unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
               (pathname-type input-file))
     (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
@@ -487,42 +504,45 @@
                   (*package* *package*)
                   (jvm::*functions-defined-in-current-file* '())
                   (*fbound-names* '())
-                  (*fasl-anonymous-package* (%make-package)))
+                  (*fasl-anonymous-package* (%make-package))
+                  (*fasl-stream* out)
+                  *forms-for-output*)
               (jvm::with-saved-compiler-policy
-                (jvm::with-file-compilation
-                  (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
-                  (%stream-terpri out)
-                  (let ((*package* (find-package '#:cl)))
-                    (write (list 'init-fasl :version *fasl-version*)
-                           :stream out)
+                  (jvm::with-file-compilation
+                      (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
                     (%stream-terpri out)
-                    (write (list 'setq '*source* *compile-file-truename*)
-                           :stream out)
-                    (%stream-terpri out))
-                  (handler-bind ((style-warning #'(lambda (c)
-                                                    (setf warnings-p t)
-                                                    ;; let outer handlers
-                                                    ;; do their thing
-                                                    (signal c)
-                                                    ;; prevent the next
-                                                    ;; handler from running:
-                                                    ;; we're a WARNING subclass
-                                                    (continue)))
-                                 ((or warning
-                                      compiler-error) #'(lambda (c)
-                                                          (declare (ignore c))
-                                                          (setf warnings-p t
-                                                                failure-p t))))
-                    (loop
-                       (let* ((*source-position* (file-position in))
-                              (jvm::*source-line-number* (stream-line-number in))
-                              (form (read in nil in))
-                              (*compiler-error-context* form))
-                         (when (eq form in)
-                           (return))
-                         (process-toplevel-form form out nil))))
-                  (dolist (name *fbound-names*)
-                    (fmakunbound name)))))))
+                    (let ((*package* (find-package '#:cl)))
+                      (write (list 'init-fasl :version *fasl-version*)
+                             :stream out)
+                      (%stream-terpri out)
+                      (write (list 'setq '*source* *compile-file-truename*)
+                             :stream out)
+                      (%stream-terpri out))
+                    (handler-bind ((style-warning #'(lambda (c)
+                                                      (setf warnings-p t)
+                                                      ;; let outer handlers
+                                                      ;; do their thing
+                                                      (signal c)
+                                                      ;; prevent the next
+                                                      ;; handler from running:
+                                                      ;; we're a WARNING subclass
+                                                      (continue)))
+                                   ((or warning
+                                        compiler-error) #'(lambda (c)
+                                        (declare (ignore c))
+                                        (setf warnings-p t
+                                              failure-p t))))
+                      (loop
+                         (let* ((*source-position* (file-position in))
+                                (jvm::*source-line-number* (stream-line-number in))
+                                (form (read in nil in))
+                                (*compiler-error-context* form))
+                           (when (eq form in)
+                             (return))
+                           (process-toplevel-form form out nil))))
+                    (finalize-fasl-output)
+                    (dolist (name *fbound-names*)
+                      (fmakunbound name)))))))
         (rename-file temp-file output-file)
 
         (when *compile-file-zip*

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	Sun Oct 25 18:35:52 2009
@@ -1948,6 +1948,8 @@
     (when (plusp (length output))
       output)))
 
+(defvar *declare-inline* nil)
+
 (defmacro declare-with-hashtable (declared-item hashtable hashtable-var
 				  item-var &body body)
   `(let* ((,hashtable-var ,hashtable)
@@ -1970,19 +1972,19 @@
 		      (declare-object symbol +lisp-symbol+
                                       +lisp-symbol-class+))))
 	 (t
-	  (let ((*code* *static-code*)
-		(s (sanitize symbol)))
-	    (setf g (symbol-name (gensym "SYM")))
-	    (when s
-	      (setf g (concatenate 'string g "_" s)))
-	    (declare-field g +lisp-symbol+ +field-access-private+)
-	    (emit 'ldc (pool-string (symbol-name symbol)))
-	    (emit 'ldc (pool-string (package-name (symbol-package symbol))))
-	    (emit-invokestatic +lisp-class+ "internInPackage"
-			       (list +java-string+ +java-string+) +lisp-symbol+)
-	    (emit 'putstatic *this-class* g +lisp-symbol+)
-	    (setf *static-code* *code*)
-	    (setf (gethash symbol ht) g))))))
+          (let ((*code* *static-code*)
+                (s (sanitize symbol)))
+            (setf g (symbol-name (gensym "SYM")))
+            (when s
+              (setf g (concatenate 'string g "_" s)))
+            (declare-field g +lisp-symbol+ +field-access-private+)
+            (emit 'ldc (pool-string (symbol-name symbol)))
+            (emit 'ldc (pool-string (package-name (symbol-package symbol))))
+            (emit-invokestatic +lisp-class+ "internInPackage"
+                               (list +java-string+ +java-string+) +lisp-symbol+)
+            (emit 'putstatic *this-class* g +lisp-symbol+)
+            (setf *static-code* *code*)
+            (setf (gethash symbol ht) g))))))
 
 (defun lookup-or-declare-symbol (symbol)
   "Returns the value-pair (VALUES field class) from which
@@ -2000,6 +2002,9 @@
   (declare-with-hashtable
    symbol *declared-symbols* ht g
    (let ((*code* *static-code*))
+     ;; there's no requirement to declare-inline here:
+     ;; keywords are constants, so they can be created any time,
+     ;; if early enough
      (setf g (symbol-name (gensym "KEY")))
      (declare-field g +lisp-symbol+ +field-access-private+)
      (emit 'ldc (pool-string (symbol-name symbol)))
@@ -2022,16 +2027,22 @@
    (multiple-value-bind
          (name class)
        (lookup-or-declare-symbol symbol)
-     (let ((*code* *static-code*))
-       (emit 'getstatic class name +lisp-symbol+)
-       (emit-invokevirtual +lisp-symbol-class+
-                           (if setf
-                               "getSymbolSetfFunctionOrDie"
-                               "getSymbolFunctionOrDie")
-                           nil +lisp-object+)
-       (emit 'putstatic *this-class* f +lisp-object+)
-       (setf *static-code* *code*)
-       (setf (gethash symbol ht) f)))))
+     (let (saved-code)
+       (let ((*code* (if *declare-inline* *code* *static-code*)))
+         (emit 'getstatic class name +lisp-symbol+)
+         (emit-invokevirtual +lisp-symbol-class+
+                             (if setf
+                                 "getSymbolSetfFunctionOrDie"
+                                 "getSymbolFunctionOrDie")
+                             nil +lisp-object+)
+         (emit 'putstatic *this-class* f +lisp-object+)
+         (if *declare-inline*
+             (setf saved-code *code*)
+             (setf *static-code* *code*))
+         (setf (gethash symbol ht) f))
+       (when *declare-inline*
+         (setf *code* saved-code))
+       f))))
 
 (defknown declare-setf-function (name) string)
 (defun declare-setf-function (name)
@@ -2045,6 +2056,7 @@
    (setf g (symbol-name (gensym "LFUN")))
    (let* ((pathname (class-file-pathname (local-function-class-file local-function)))
 	  (*code* *static-code*))
+     ;; fixme *declare-inline*
      (declare-field g +lisp-object+ +field-access-default+)
      (emit 'ldc (pool-string (file-namestring pathname)))
      (emit-invokestatic +lisp-class+ "loadCompiledFunction"
@@ -2059,6 +2071,7 @@
   (declare-with-hashtable
    n *declared-integers* ht g
    (let ((*code* *static-code*))
+     ;; no need to *declare-inline*: constants
      (setf g (format nil "FIXNUM_~A~D"
 		     (if (minusp n) "MINUS_" "")
 		     (abs n)))
@@ -2080,6 +2093,7 @@
    n *declared-integers* ht g
    (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym))))
    (let ((*code* *static-code*))
+     ;; no need to *declare-inline*: constants
      (declare-field g +lisp-integer+ +field-access-private+)
      (cond ((<= most-negative-java-long n most-positive-java-long)
 ;;	    (setf g (format nil "BIGNUM_~A~D"
@@ -2104,6 +2118,7 @@
   (declare-with-hashtable
    s *declared-floats* ht g
    (let* ((*code* *static-code*))
+     ;; no need to *declare-inline*: constants
      (setf g (concatenate 'string "FLOAT_" (symbol-name (gensym))))
      (declare-field g +lisp-single-float+ +field-access-private+)
      (emit 'new +lisp-single-float-class+)
@@ -2119,6 +2134,7 @@
   (declare-with-hashtable
    d *declared-doubles* ht g
    (let ((*code* *static-code*))
+     ;; no need to *declare-inline*: constants
      (setf g (concatenate 'string "DOUBLE_" (symbol-name (gensym))))
      (declare-field g +lisp-double-float+ +field-access-private+)
      (emit 'new +lisp-double-float-class+)
@@ -2134,6 +2150,7 @@
   (let ((g (symbol-name (gensym "CHAR")))
         (n (char-code c))
         (*code* *static-code*))
+     ;; no need to *declare-inline*: constants
     (declare-field g +lisp-character+ +field-access-private+)
     (cond ((<= 0 n 255)
            (emit 'getstatic +lisp-character-class+ "constants" +lisp-character-array+)
@@ -2151,23 +2168,31 @@
 (defknown declare-object-as-string (t &optional t) string)
 (defun declare-object-as-string (obj &optional (obj-ref +lisp-object+)
                                      obj-class)
-  (let* ((g (symbol-name (gensym "OBJSTR")))
-         (s (with-output-to-string (stream) (dump-form obj stream)))
-         (*code* *static-code*))
-    (declare-field g obj-ref +field-access-private+)
-    (emit 'ldc (pool-string s))
-    (emit-invokestatic +lisp-class+ "readObjectFromString"
-                       (list +java-string+) +lisp-object+)
-    (when (and obj-class (string/= obj-class +lisp-object+))
-      (emit 'checkcast obj-class))
-    (emit 'putstatic *this-class* g obj-ref)
-    (setf *static-code* *code*)
+  (let (saved-code
+        (g (symbol-name (gensym "OBJSTR"))))
+    (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
+           (*code* (if *declare-inline* *code* *static-code*)))
+      ;; strings may contain evaluated bits which may depend on
+      ;; previous statements
+      (declare-field g obj-ref +field-access-private+)
+      (emit 'ldc (pool-string s))
+      (emit-invokestatic +lisp-class+ "readObjectFromString"
+                         (list +java-string+) +lisp-object+)
+      (when (and obj-class (string/= obj-class +lisp-object+))
+        (emit 'checkcast obj-class))
+      (emit 'putstatic *this-class* g obj-ref)
+      (if *declare-inline*
+          (setf saved-code *code*)
+          (setf *static-code* *code*)))
+    (when *declare-inline*
+      (setf *code* saved-code))
     g))
 
 (defun declare-load-time-value (obj)
   (let* ((g (symbol-name (gensym "LTV")))
          (s (with-output-to-string (stream) (dump-form obj stream)))
          (*code* *static-code*))
+    ;; fixme *declare-inline*?
     (declare-field g +lisp-object+ +field-access-private+)
     (emit 'ldc (pool-string s))
     (emit-invokestatic +lisp-class+ "readObjectFromString"
@@ -2186,6 +2211,7 @@
   (let* ((g (symbol-name (gensym "INSTANCE")))
          (s (with-output-to-string (stream) (dump-form obj stream)))
          (*code* *static-code*))
+    ;; fixme *declare-inline*?
     (declare-field g +lisp-object+ +field-access-private+)
     (emit 'ldc (pool-string s))
     (emit-invokestatic +lisp-class+ "readObjectFromString"
@@ -2197,17 +2223,22 @@
     g))
 
 (defun declare-package (obj)
-  (let* ((g (symbol-name (gensym "PKG")))
-         (*print-level* nil)
-         (*print-length* nil)
-         (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
-         (*code* *static-code*))
-    (declare-field g +lisp-object+ +field-access-private+)
-    (emit 'ldc (pool-string s))
-    (emit-invokestatic +lisp-class+ "readObjectFromString"
-                       (list +java-string+) +lisp-object+)
-    (emit 'putstatic *this-class* g +lisp-object+)
-    (setf *static-code* *code*)
+  (let (saved-code
+        (g (symbol-name (gensym "PKG"))))
+    (let* ((*print-level* nil)
+           (*print-length* nil)
+           (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
+           (*code* *static-code*))
+      (declare-field g +lisp-object+ +field-access-private+)
+      (emit 'ldc (pool-string s))
+      (emit-invokestatic +lisp-class+ "readObjectFromString"
+                         (list +java-string+) +lisp-object+)
+      (emit 'putstatic *this-class* g +lisp-object+)
+      (if *declare-inline*
+          (setf saved-code *code*)
+          (setf *static-code* *code*)))
+    (when *declare-inline*
+      (setf *code* saved-code))
     g))
 
 (declaim (ftype (function (t &optional t) string) declare-object))
@@ -2218,6 +2249,7 @@
 
 The field type of the object is specified by OBJ-REF."
   (let ((key (symbol-name (gensym "OBJ"))))
+    ;; fixme *declare-inline*?
     (remember key obj)
     (let* ((g1 (declare-string key))
            (g2 (symbol-name (gensym "O2BJ"))))
@@ -2233,35 +2265,41 @@
       g2))))
 
 (defun declare-lambda (obj)
-  (let* ((g (symbol-name (gensym "LAMBDA")))
-         (*print-level* nil)
-         (*print-length* nil)
-         (s (format nil "~S" obj))
-         (*code* *static-code*))
-    (declare-field g +lisp-object+ +field-access-private+)
-    (emit 'ldc
-          (pool-string s))
-    (emit-invokestatic +lisp-class+ "readObjectFromString"
-                       (list +java-string+) +lisp-object+)
-    (emit-invokestatic +lisp-class+ "coerceToFunction"
-                       (lisp-object-arg-types 1) +lisp-object+)
-    (emit 'putstatic *this-class* g +lisp-object+)
-    (setf *static-code* *code*)
+  (let (saved-code
+        (g (symbol-name (gensym "LAMBDA"))))
+    (let* ((*print-level* nil)
+           (*print-length* nil)
+           (s (format nil "~S" obj))
+           (*code* *static-code*))
+      (declare-field g +lisp-object+ +field-access-private+)
+      (emit 'ldc
+            (pool-string s))
+      (emit-invokestatic +lisp-class+ "readObjectFromString"
+                         (list +java-string+) +lisp-object+)
+      (emit-invokestatic +lisp-class+ "coerceToFunction"
+                         (lisp-object-arg-types 1) +lisp-object+)
+      (emit 'putstatic *this-class* g +lisp-object+)
+      (if *declare-inline*
+          (setf saved-code *code*)
+          (setf *static-code* *code*)))
+    (when *declare-inline*
+      (setf *code* saved-code))
     g))
 
 (defun declare-string (string)
   (declare-with-hashtable
    string *declared-strings* ht g
    (let ((*code* *static-code*))
-        (setf g (symbol-name (gensym "STR")))
-        (declare-field g +lisp-simple-string+ +field-access-private+)
-        (emit 'new +lisp-simple-string-class+)
-        (emit 'dup)
-        (emit 'ldc (pool-string string))
-        (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))
-        (emit 'putstatic *this-class* g +lisp-simple-string+)
-        (setf *static-code* *code*)
-        (setf (gethash string ht) g))))
+     ;; constant: no need to *declare-inline*
+     (setf g (symbol-name (gensym "STR")))
+     (declare-field g +lisp-simple-string+ +field-access-private+)
+     (emit 'new +lisp-simple-string-class+)
+     (emit 'dup)
+     (emit 'ldc (pool-string string))
+     (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))
+     (emit 'putstatic *this-class* g +lisp-simple-string+)
+     (setf *static-code* *code*)
+     (setf (gethash string ht) g))))
 
 (defknown compile-constant (t t t) t)
 (defun compile-constant (form target representation)
@@ -8448,7 +8486,7 @@
   `(lambda ,(cadr form)
      (error 'program-error :format-control "Execution of a form compiled with errors.")))
 
-(defun compile-defun (name form environment filespec stream)
+(defun compile-defun (name form environment filespec stream *declare-inline*)
   "Compiles a lambda expression `form'. If `filespec' is NIL,
 a random Java class name is generated, if it is non-NIL, it's used
 to derive a Java class name from."
@@ -8572,7 +8610,7 @@
           (setf compiled-function
                 (load-compiled-function
                  (with-open-stream (s (sys::%make-byte-array-output-stream))
-                   (compile-defun name expr env nil s)
+                   (compile-defun name expr env nil s nil)
                    (finish-output s)
                    (sys::%get-output-stream-bytes s))))))
     (when (and name (functionp compiled-function))



From ehuelsmann at common-lisp.net  Mon Oct 26 17:27:40 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 26 Oct 2009 13:27:40 -0400
Subject: [armedbear-cvs] r12227 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Mon Oct 26 13:27:36 2009
New Revision: 12227

Log:
Fix broken merge causing build breakage.

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 Oct 26 13:27:36 2009
@@ -377,8 +377,8 @@
                                  (eq 'QUOTE (car arg)))))
               (cdr form))))
 
-(declaim (ftype (function (t) t) convert-toplevel-form))
-(defun convert-toplevel-form (form)
+(declaim (ftype (function (t t) t) convert-toplevel-form))
+(defun convert-toplevel-form (form declare-inline)
   (when (or (simple-toplevel-form-p form)
             (and (eq (car form) 'SETQ)
                  ;; for SETQ, look at the evaluated part



From ehuelsmann at common-lisp.net  Mon Oct 26 20:18:05 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 26 Oct 2009 16:18:05 -0400
Subject: [armedbear-cvs] r12228 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Mon Oct 26 16:18:01 2009
New Revision: 12228

Log:
Remove unused function (PROCESS-SPECIAL-DECLARATIONS).

Modified:
   trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp	Mon Oct 26 16:18:01 2009
@@ -33,7 +33,6 @@
 
 (export '(*inline-declarations*
           process-optimization-declarations
-          process-special-declarations
           inline-p notinline-p inline-expansion expand-inline
           *defined-functions* *undefined-functions* note-name-defined))
 
@@ -83,19 +82,6 @@
                  (setf *explain* (remove quality *explain*)))))))))
   t)
 
-;; Returns list of declared specials.
-(declaim (ftype (function (list) list) process-special-declarations))
-(defun process-special-declarations (forms)
-  (let ((specials nil))
-    (dolist (form forms)
-      (unless (and (consp form) (eq (%car form) 'DECLARE))
-        (return))
-      (let ((decls (%cdr form)))
-        (dolist (decl decls)
-          (when (eq (car decl) 'special)
-            (setq specials (append (cdr decl) specials))))))
-    specials))
-
 (declaim (ftype (function (t) t) inline-p))
 (defun inline-p (name)
   (declare (optimize speed))



From ehuelsmann at common-lisp.net  Mon Oct 26 21:20:38 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 26 Oct 2009 17:20:38 -0400
Subject: [armedbear-cvs] r12229 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Mon Oct 26 17:20:36 2009
New Revision: 12229

Log:
Move more to functions to the autoloader, to be loaded when necessary.

Modified:
   trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
   trunk/abcl/src/org/armedbear/lisp/boot.lisp
   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp
   trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	Mon Oct 26 17:20:36 2009
@@ -376,3 +376,29 @@
 (export 'compiler-let)
 (autoload 'compiler-let)
 
+
+(in-package "SYSTEM")
+
+;; #:SYSTEM in PRECOMPILER.LISP
+
+
+(export '(process-optimization-declarations
+          inline-p notinline-p inline-expansion expand-inline
+          note-name-defined precompile))
+(autoload '(process-optimization-declarations
+            inline-p notinline-p inline-expansion expand-inline
+            note-name-defined precompile) "precompiler")
+
+
+
+;; #:SYSTEM in SOURCE-TRANSFORM.LISP
+
+(export '(source-transform define-source-transform expand-source-transform))
+(autoload '(source-transform define-source-transform set-source-transform
+            expand-source-transform)
+    "source-transform")
+
+(in-package "PRECOMPILER")
+
+(export '(precompile-form precompile))
+(autoload '(precompile-form) "precompiler")
\ No newline at end of file

Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/boot.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/boot.lisp	Mon Oct 26 17:20:36 2009
@@ -159,9 +159,6 @@
 (load-system-file "compiler-macro")
 (load-system-file "subtypep")
 (load-system-file "typep")
-(load-system-file "compiler-error")
-(load-system-file "source-transform")
-(load-system-file "precompiler")
 (load-system-file "signal")
 (load-system-file "list")
 (load-system-file "sequences")

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 Oct 26 17:20:36 2009
@@ -31,7 +31,8 @@
 
 (in-package #:system)
 
-(require '#:jvm)
+(require "JVM")
+;; (require "COMPILER-ERROR") already made accessible through JVM
 
 (defvar *fbound-names*)
 

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Mon Oct 26 17:20:36 2009
@@ -40,6 +40,7 @@
   (require "CLOS")
   (require "PRINT-OBJECT")
   (require "COMPILER-TYPES")
+  (require "COMPILER-ERROR")
   (require "KNOWN-FUNCTIONS")
   (require "KNOWN-SYMBOLS")
   (require "DUMP-FORM")

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 Oct 26 17:20:36 2009
@@ -31,6 +31,7 @@
 
 (in-package "SYSTEM")
 
+
 (export '(*inline-declarations*
           process-optimization-declarations
           inline-p notinline-p inline-expansion expand-inline
@@ -473,7 +474,7 @@
 
 (defun precompile-progv (form)
   (if (< (length form) 3)
-      (compiler-error "Not enough arguments for ~S." 'progv)
+      (error "Not enough arguments for ~S." 'progv)
       (list* 'PROGV (mapcar #'precompile1 (%cdr form)))))
 
 (defun precompile-setf (form)



From ehuelsmann at common-lisp.net  Mon Oct 26 22:41:32 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 26 Oct 2009 18:41:32 -0400
Subject: [armedbear-cvs] r12230 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Mon Oct 26 18:41:29 2009
New Revision: 12230

Log:
More efficient startup: only autoload pprint[.lisp] if necessary.

Modified:
   trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
   trunk/abcl/src/org/armedbear/lisp/boot.lisp
   trunk/abcl/src/org/armedbear/lisp/pprint.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp	Mon Oct 26 18:41:29 2009
@@ -401,4 +401,28 @@
 (in-package "PRECOMPILER")
 
 (export '(precompile-form precompile))
-(autoload '(precompile-form) "precompiler")
\ No newline at end of file
+(autoload '(precompile-form) "precompiler")
+
+
+;; items in the XP package (pprint.lisp)
+
+(in-package "XP")
+
+(sys::autoload '(xp-structure-p write-string++ output-pretty-object
+                 pprint-logical-block+ maybe-initiate-xp-printing
+                 check-block-abbreviation start-block end-block
+                 pprint-pop-check+) "pprint")
+
+(sys::autoload-macro '(pprint-logical-block+ pprint-pop+) "pprint")
+
+(in-package "COMMON-LISP")
+
+(sys::autoload '(write print prin1 princ pprint write-to-string
+            prin1-to-string princ-to-string write-char
+            write-string write-line terpri finish-output
+            fresh-line force-output clear-output
+            pprint-newline pprint-indent pprint-tab pprint-linear
+            pprint-fill pprint-tabular) "pprint")
+
+(sys::autoload-macro '(pprint-logical-block) "pprint")
+

Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/boot.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/boot.lisp	Mon Oct 26 18:41:29 2009
@@ -176,7 +176,6 @@
 (load-system-file "debug")
 (load-system-file "print")
 (load-system-file "pprint-dispatch")
-(load-system-file "pprint")
 (load-system-file "defsetf")
 (load-system-file "package")
 

Modified: trunk/abcl/src/org/armedbear/lisp/pprint.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/pprint.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/pprint.lisp	Mon Oct 26 18:41:29 2009
@@ -1358,7 +1358,7 @@
          (assert nil)
          (sys:output-object object stream))))
 
-(provide 'pprint)
+(provide "PPRINT")
 
 ;------------------------------------------------------------------------
 



From ehuelsmann at common-lisp.net  Tue Oct 27 21:57:25 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Tue, 27 Oct 2009 17:57:25 -0400
Subject: [armedbear-cvs] r12231 - in trunk/abcl/examples/abcl: .
	abcl_appengine abcl_appengine/src abcl_appengine/src/META-INF
	abcl_appengine/src/abcl_ae abcl_appengine/war
	abcl_appengine/war/WEB-INF abcl_appengine/war/WEB-INF/classes
	abcl_appengine/war/WEB-INF/classes/META-INF
	abcl_appengine/war/WEB-INF/classes/abcl_ae
	abcl_appengine/war/WEB-INF/lib abcl_appengine/war/fasls
Message-ID: 

Author: ehuelsmann
Date: Tue Oct 27 17:57:22 2009
New Revision: 12231

Log:
Google App Engine (GAE) basic Hello World application progress.

Most of the code by Alex Muscar.

Added:
   trunk/abcl/examples/abcl/abcl_appengine/
   trunk/abcl/examples/abcl/abcl_appengine/build.xml
   trunk/abcl/examples/abcl/abcl_appengine/src/
   trunk/abcl/examples/abcl/abcl_appengine/src/META-INF/
   trunk/abcl/examples/abcl/abcl_appengine/src/abcl_ae/
   trunk/abcl/examples/abcl/abcl_appengine/src/abcl_ae/AbclInit.java
   trunk/abcl/examples/abcl/abcl_appengine/src/abcl_ae/HelloWorldServlet.java
   trunk/abcl/examples/abcl/abcl_appengine/src/first-servlet.lisp
   trunk/abcl/examples/abcl/abcl_appengine/war/
   trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/
   trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/appengine-web.xml
   trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/classes/
   trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/classes/META-INF/
   trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/classes/abcl_ae/
   trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/classes/first-servlet.lisp
   trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/lib/
   trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/web.xml
   trunk/abcl/examples/abcl/abcl_appengine/war/fasls/
Modified:
   trunk/abcl/examples/abcl/README

Modified: trunk/abcl/examples/abcl/README
==============================================================================
--- trunk/abcl/examples/abcl/README	(original)
+++ trunk/abcl/examples/abcl/README	Tue Oct 27 17:57:22 2009
@@ -1,33 +1,44 @@
-ABCL Examples Building and Running Instructions
-===============================================
-
-code by Ville Voutilainen
-instructions by Blake McBride
-updated by Mark Evenson
-
-In general, to compile a Java class file (like Main.java for example
-in the 'java_exception_in_lisp' subdirectory) use:
-
-	cmd$ cd java_exception_in_lisp
-	cmd$ javac  -cp ../../../dist/abcl.jar  Main.java
-
-where the "../../../dist/abcl.jar" represents the path to your
-abcl.jar file, which is built via the Ant based build.  This path
-could be slightly different depending on how the system was
-constructed, and possibly due to operating system conventions for
-specifying relative paths.  However you resolve this locally, we'll
-refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these
-instructions.
-
-This compiles the Java source file "Main.java" into a JVM runtime or
-class file named "Main.class".
-
-To run the example (Main.class for example) from a Unix-like OS use:
-
-	cmd$ java  -cp $ABCL_ROOT/dist/abcl.jar:.  Main
-
-or in Windows use:
-
-	cmd$  java  -cp  $ABCL_ROOT/dist/abcl.jar;.  Main
-
-where "Main" is the initial class to run in your Java program.
+ABCL Examples Building and Running Instructions
+===============================================
+
+code by Ville Voutilainen
+(abcl_appengine code by Alex Muscar)
+instructions by Blake McBride
+updated by Mark Evenson
+
+In general, to compile a Java class file (like Main.java for example
+in the 'java_exception_in_lisp' subdirectory) use:
+
+	cmd$ cd java_exception_in_lisp
+	cmd$ javac  -cp ../../../dist/abcl.jar  Main.java
+
+where the "../../../dist/abcl.jar" represents the path to your
+abcl.jar file, which is built via the Ant based build.  This path
+could be slightly different depending on how the system was
+constructed, and possibly due to operating system conventions for
+specifying relative paths.  However you resolve this locally, we'll
+refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these
+instructions.
+
+This compiles the Java source file "Main.java" into a JVM runtime or
+class file named "Main.class".
+
+To run the example (Main.class for example) from a Unix-like OS use:
+
+	cmd$ java  -cp $ABCL_ROOT/dist/abcl.jar:.  Main
+
+or in Windows use:
+
+	cmd$  java  -cp  $ABCL_ROOT/dist/abcl.jar;.  Main
+
+where "Main" is the initial class to run in your Java program.
+
+
+abcl_appengine
+==============
+
+This example shows how to run your servlet off ABCL in general
+and in Google App Engine (GAE) in particular.
+
+When uploading your code to the server, be sure to put abcl.jar
+in war/WEB-INF/lib.

Added: trunk/abcl/examples/abcl/abcl_appengine/build.xml
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/abcl/abcl_appengine/build.xml	Tue Oct 27 17:57:22 2009
@@ -0,0 +1,61 @@
+
+  
+  
+  
+	
+	
+	  
+	
+	
+	  
+	
+  
+  
+	
+	  
+		  
+	  
+	  
+		  
+	  
+	
+	
+	  
+		
+	  
+	
+  
+  
+	
+	
+	  
+		  
+	  
+	
+	
+  
+  
+    
+      
+      
+      
+    
+  
+  
+	
+  
+  
+	
+  
+
\ No newline at end of file

Added: trunk/abcl/examples/abcl/abcl_appengine/src/abcl_ae/AbclInit.java
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/abcl/abcl_appengine/src/abcl_ae/AbclInit.java	Tue Oct 27 17:57:22 2009
@@ -0,0 +1,95 @@
+/*package abcl_ae;
+
+import java.io.FileInputStream;
+import java.io.PrintWriter;
+import java.io.StringWriter;
+import java.io.File;
+//import java.io.IOException;
+//import java.io.FileNotFoundException;
+
+import org.armedbear.lisp.Lisp;
+import org.armedbear.lisp.Interpreter;
+import org.armedbear.lisp.Symbol;
+import org.armedbear.lisp.Pathname;
+import org.armedbear.lisp.Stream;
+import org.armedbear.lisp.Load;
+import org.armedbear.lisp.ConditionThrowable;
+
+public final class AbclInit {
+	static Symbol doGet = null;
+	static boolean hasErrors = false;
+	static String message = "Success";
+	
+	static {
+		FileInputStream in = null;
+		
+		try {
+			in = new FileInputStream("fasls/first-servlet.abcl");
+			Load.load("fasls/first-servlet.abcl");
+			
+			doGet = Lisp.internInPackage("FIRST-SERVLET", "DO-GET");
+		} catch (ConditionThrowable condition) {
+			// How do we handle exceptions?
+			hasErrors = true;
+			message = condition.toString();
+		} catch (Exception e) {
+			// How do we handle exceptions?
+			hasErrors = true;
+			StringWriter sw = new StringWriter();
+			PrintWriter pw = new PrintWriter(sw, true);
+			e.printStackTrace(pw);
+			pw.flush();
+			sw.flush();
+			message = sw.toString();
+		} finally {
+			try {
+				in.close();
+			} catch (Exception e) {
+				hasErrors = true;
+				StringWriter sw = new StringWriter();
+				PrintWriter pw = new PrintWriter(sw, true);
+				e.printStackTrace(pw);
+				pw.flush();
+				sw.flush();
+				message = sw.toString();
+			}
+		}
+	}
+}*/
+
+package abcl_ae;
+
+import java.io.FileInputStream;
+import java.io.IOException;
+
+import org.armedbear.lisp.Lisp;
+import org.armedbear.lisp.Load;
+import org.armedbear.lisp.Interpreter;
+import org.armedbear.lisp.Symbol;
+import org.armedbear.lisp.Pathname;
+import org.armedbear.lisp.ConditionThrowable;
+
+public final class AbclInit {
+	static private Object lock = new Object();
+	static private boolean initialized = false;
+
+	// package access level
+	static void init() {
+		if (initialized)
+			return;
+			
+		synchronized (lock) {
+			if (initialized)
+				return;
+				
+			try {
+				Interpreter.initializeLisp();
+				Load.load("fasls/first-servlet.abcl");
+			}
+			catch (ConditionThrowable ct) { }
+			
+			initialized = true;
+		}
+	}
+
+}
\ No newline at end of file

Added: trunk/abcl/examples/abcl/abcl_appengine/src/abcl_ae/HelloWorldServlet.java
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/abcl/abcl_appengine/src/abcl_ae/HelloWorldServlet.java	Tue Oct 27 17:57:22 2009
@@ -0,0 +1,97 @@
+/*package abcl_ae;
+
+import java.io.IOException;
+import javax.servlet.http.*;
+
+import org.armedbear.lisp.LispThread;
+import org.armedbear.lisp.Lisp;
+import org.armedbear.lisp.Symbol;
+import org.armedbear.lisp.Stream;
+import org.armedbear.lisp.SpecialBinding;
+import org.armedbear.lisp.ConditionThrowable;
+
+public class HelloWorldServlet extends HttpServlet {
+	public void doGet(HttpServletRequest req, HttpServletResponse resp)
+		throws IOException {
+		
+		if (AbclInit.hasErrors)
+		{
+			resp.setContentType("text/plain");
+			resp.getWriter().println(AbclInit.message);
+			return;
+		}
+		
+		// Set the default Lisp output stream to the servlet's output stream.
+		LispThread currentThread = LispThread.currentThread();
+		SpecialBinding lastSpecialBinding = currentThread.lastSpecialBinding;
+		Stream out = new Stream(resp.getOutputStream(), Symbol.CHARACTER, false);
+		
+		currentThread.bindSpecial(Symbol.STANDARD_OUTPUT, out);
+		
+		try {
+			if (AbclInit.doGet == null)
+			{
+				resp.setContentType("text/plain");
+				resp.getWriter().println(AbclInit.message);
+				return;
+			}
+			
+			// Run the Lisp handler.
+			currentThread.execute(AbclInit.doGet);
+		} catch (ConditionThrowable condition) {
+			resp.setContentType("text/plain");
+			resp.getWriter().println(condition.toString());
+		} finally {
+			// Restore the default Lisp output stream.
+			currentThread.lastSpecialBinding = lastSpecialBinding;
+		}
+	}
+}*/
+
+package abcl_ae;
+
+import java.io.IOException;
+import javax.servlet.http.*;
+import javax.servlet.*;
+
+import org.armedbear.lisp.Interpreter;
+import org.armedbear.lisp.LispThread;
+import org.armedbear.lisp.Lisp;
+import org.armedbear.lisp.Symbol;
+import org.armedbear.lisp.SpecialBinding;
+import org.armedbear.lisp.ConditionThrowable;
+import org.armedbear.lisp.Load;
+
+public class HelloWorldServlet extends HttpServlet {
+
+	static private Symbol doGet = null;
+
+	public void init() throws ServletException {
+		AbclInit.init();
+		try {
+			doGet = Lisp.internInPackage("DO-GET", "FIRST-SERVLET");
+		}
+		catch (ConditionThrowable ct) { }
+	}
+
+
+	public void doGet(HttpServletRequest req, HttpServletResponse resp)
+			throws IOException {
+
+		LispThread currentThread = LispThread.currentThread();
+
+		SpecialBinding lastSpecialBinding = currentThread.lastSpecialBinding;
+		currentThread.bindSpecial(
+			Symbol.STANDARD_OUTPUT, 
+			new org.armedbear.lisp.Stream(resp.getOutputStream(), Symbol.CHARACTER, false));
+
+		try {
+			currentThread.execute(doGet);
+		} catch (ConditionThrowable condition) {
+			resp.setContentType("text/plain");
+			resp.getWriter().println(condition.toString());
+		} finally {
+			currentThread.lastSpecialBinding = lastSpecialBinding;
+		}
+	}
+}
\ No newline at end of file

Added: trunk/abcl/examples/abcl/abcl_appengine/src/first-servlet.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/abcl/abcl_appengine/src/first-servlet.lisp	Tue Oct 27 17:57:22 2009
@@ -0,0 +1,8 @@
+(defpackage #:first-servlet
+  (:use :cl)
+  (:export #:do-get))
+
+(in-package #:first-servlet)
+
+(defun do-get ()
+  (format t "Hello, World!~%"))
\ No newline at end of file

Added: trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/appengine-web.xml
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/appengine-web.xml	Tue Oct 27 17:57:22 2009
@@ -0,0 +1,5 @@
+
+
+	abcl-test
+	1
+

Added: trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/classes/first-servlet.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/classes/first-servlet.lisp	Tue Oct 27 17:57:22 2009
@@ -0,0 +1,8 @@
+(defpackage #:first-servlet
+  (:use :cl)
+  (:export #:do-get))
+
+(in-package #:first-servlet)
+
+(defun do-get ()
+  (format t "Hello, World!~%"))
\ No newline at end of file

Added: trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/web.xml
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/abcl/abcl_appengine/war/WEB-INF/web.xml	Tue Oct 27 17:57:22 2009
@@ -0,0 +1,18 @@
+
+
+
+
+	
+		hello
+		abcl_ae.HelloWorldServlet
+	
+	
+		hello
+		/hello
+	
+	
+		/index.html
+	
+
\ No newline at end of file



From ehuelsmann at common-lisp.net  Tue Oct 27 22:38:21 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Tue, 27 Oct 2009 18:38:21 -0400
Subject: [armedbear-cvs] r12232 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Tue Oct 27 18:38:19 2009
New Revision: 12232

Log:
Additional *declare-inline* cases in the DECLARE-* functions.

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	Tue Oct 27 18:38:19 2009
@@ -1972,19 +1972,28 @@
 		      (declare-object symbol +lisp-symbol+
                                       +lisp-symbol-class+))))
 	 (t
-          (let ((*code* *static-code*)
-                (s (sanitize symbol)))
-            (setf g (symbol-name (gensym "SYM")))
-            (when s
-              (setf g (concatenate 'string g "_" s)))
-            (declare-field g +lisp-symbol+ +field-access-private+)
-            (emit 'ldc (pool-string (symbol-name symbol)))
-            (emit 'ldc (pool-string (package-name (symbol-package symbol))))
-            (emit-invokestatic +lisp-class+ "internInPackage"
-                               (list +java-string+ +java-string+) +lisp-symbol+)
-            (emit 'putstatic *this-class* g +lisp-symbol+)
-            (setf *static-code* *code*)
-            (setf (gethash symbol ht) g))))))
+          (let (saved-code)
+            (let ((*code* (if *declare-inline* *code*) *static-code*)
+                  (s (sanitize symbol)))
+              ;; *declare-inline*, because the code below assumes the
+              ;; package to exist, which can be in a previous statement;
+              ;; thus we can't create the symbol out-of-band.
+              (setf g (symbol-name (gensym "SYM")))
+              (when s
+                (setf g (concatenate 'string g "_" s)))
+              (declare-field g +lisp-symbol+ +field-access-private+)
+              (emit 'ldc (pool-string (symbol-name symbol)))
+              (emit 'ldc (pool-string (package-name (symbol-package symbol))))
+              (emit-invokestatic +lisp-class+ "internInPackage"
+                                 (list +java-string+ +java-string+)
+                                 +lisp-symbol+)
+              (emit 'putstatic *this-class* g +lisp-symbol+)
+              (if *declare-inline*
+                  (setf saved-code *code*)
+                  (setf *static-code* *code*))
+              (setf (gethash symbol ht) g))
+            (when *declare-inline*
+              (setf *code* saved-code)))))))
 
 (defun lookup-or-declare-symbol (symbol)
   "Returns the value-pair (VALUES field class) from which
@@ -2189,18 +2198,25 @@
     g))
 
 (defun declare-load-time-value (obj)
-  (let* ((g (symbol-name (gensym "LTV")))
-         (s (with-output-to-string (stream) (dump-form obj stream)))
-         (*code* *static-code*))
-    ;; fixme *declare-inline*?
-    (declare-field g +lisp-object+ +field-access-private+)
-    (emit 'ldc (pool-string s))
-    (emit-invokestatic +lisp-class+ "readObjectFromString"
-                       (list +java-string+) +lisp-object+)
-    (emit-invokestatic +lisp-class+ "loadTimeValue"
-                       (lisp-object-arg-types 1) +lisp-object+)
-    (emit 'putstatic *this-class* g +lisp-object+)
-    (setf *static-code* *code*)
+  (let ((g (symbol-name (gensym "LTV")))
+        saved-code)
+    (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
+           (*code* (if *declare-inline* *code* *static-code*)))
+      ;; The readObjectFromString call may require evaluation of
+      ;; lisp code in the string (think #.() syntax), of which the outcome
+      ;; may depend on something which was declared inline
+      (declare-field g +lisp-object+ +field-access-private+)
+      (emit 'ldc (pool-string s))
+      (emit-invokestatic +lisp-class+ "readObjectFromString"
+                         (list +java-string+) +lisp-object+)
+      (emit-invokestatic +lisp-class+ "loadTimeValue"
+                         (lisp-object-arg-types 1) +lisp-object+)
+      (emit 'putstatic *this-class* g +lisp-object+)
+      (if *declared-inline*
+          (setf saved-code *code*)
+          (setf *static-code* *code*)))
+    (when *declared-inline*
+      (setf *code* saved-code))
     g))
 
 (defknown declare-instance (t) t)
@@ -2208,18 +2224,25 @@
   (aver (not (null *file-compilation*)))
   (aver (or (structure-object-p obj) (standard-object-p obj)
             (java:java-object-p obj)))
-  (let* ((g (symbol-name (gensym "INSTANCE")))
-         (s (with-output-to-string (stream) (dump-form obj stream)))
-         (*code* *static-code*))
-    ;; fixme *declare-inline*?
-    (declare-field g +lisp-object+ +field-access-private+)
-    (emit 'ldc (pool-string s))
-    (emit-invokestatic +lisp-class+ "readObjectFromString"
-                       (list +java-string+) +lisp-object+)
-    (emit-invokestatic +lisp-class+ "loadTimeValue"
-                       (lisp-object-arg-types 1) +lisp-object+)
-    (emit 'putstatic *this-class* g +lisp-object+)
-    (setf *static-code* *code*)
+  (let ((g (symbol-name (gensym "INSTANCE")))
+        saved-code)
+    (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
+           (*code* (if *declare-inline* *code* *static-code*)))
+      ;; The readObjectFromString call may require evaluation of
+      ;; lisp code in the string (think #.() syntax), of which the outcome
+      ;; may depend on something which was declared inline
+      (declare-field g +lisp-object+ +field-access-private+)
+      (emit 'ldc (pool-string s))
+      (emit-invokestatic +lisp-class+ "readObjectFromString"
+                         (list +java-string+) +lisp-object+)
+      (emit-invokestatic +lisp-class+ "loadTimeValue"
+                         (lisp-object-arg-types 1) +lisp-object+)
+      (emit 'putstatic *this-class* g +lisp-object+)
+      (if *declare-inline*
+          (setf saved-code *code*)
+          (setf *static-code* *code*)))
+    (when *declare-inline*
+      (setf *code* saved-code))
     g))
 
 (defun declare-package (obj)
@@ -2228,7 +2251,7 @@
     (let* ((*print-level* nil)
            (*print-length* nil)
            (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
-           (*code* *static-code*))
+           (*code* (if *declare-inline* *code* *static-code*)))
       (declare-field g +lisp-object+ +field-access-private+)
       (emit 'ldc (pool-string s))
       (emit-invokestatic +lisp-class+ "readObjectFromString"
@@ -2254,15 +2277,15 @@
     (let* ((g1 (declare-string key))
            (g2 (symbol-name (gensym "O2BJ"))))
       (let* ((*code* *static-code*))
-      (declare-field g2 obj-ref +field-access-private+)
-      (emit 'getstatic *this-class* g1 +lisp-simple-string+)
-      (emit-invokestatic +lisp-class+ "recall"
-                         (list +lisp-simple-string+) +lisp-object+)
-      (when (and obj-class (string/= obj-class +lisp-object-class+))
-        (emit 'checkcast obj-class))
-      (emit 'putstatic *this-class* g2 obj-ref)
-      (setf *static-code* *code*)
-      g2))))
+        (declare-field g2 obj-ref +field-access-private+)
+        (emit 'getstatic *this-class* g1 +lisp-simple-string+)
+        (emit-invokestatic +lisp-class+ "recall"
+                           (list +lisp-simple-string+) +lisp-object+)
+        (when (and obj-class (string/= obj-class +lisp-object-class+))
+          (emit 'checkcast obj-class))
+        (emit 'putstatic *this-class* g2 obj-ref)
+        (setf *static-code* *code*)
+        g2))))
 
 (defun declare-lambda (obj)
   (let (saved-code
@@ -2270,7 +2293,7 @@
     (let* ((*print-level* nil)
            (*print-length* nil)
            (s (format nil "~S" obj))
-           (*code* *static-code*))
+           (*code* (if *declare-inline* *code* *static-code*)))
       (declare-field g +lisp-object+ +field-access-private+)
       (emit 'ldc
             (pool-string s))



From ehuelsmann at common-lisp.net  Thu Oct 29 20:38:50 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 29 Oct 2009 16:38:50 -0400
Subject: [armedbear-cvs] r12233 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Thu Oct 29 16:38:46 2009
New Revision: 12233

Log:
Fix paren placement and variable naming.


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	Thu Oct 29 16:38:46 2009
@@ -1973,7 +1973,7 @@
                                       +lisp-symbol-class+))))
 	 (t
           (let (saved-code)
-            (let ((*code* (if *declare-inline* *code*) *static-code*)
+            (let ((*code* (if *declare-inline* *code* *static-code*))
                   (s (sanitize symbol)))
               ;; *declare-inline*, because the code below assumes the
               ;; package to exist, which can be in a previous statement;
@@ -2212,10 +2212,10 @@
       (emit-invokestatic +lisp-class+ "loadTimeValue"
                          (lisp-object-arg-types 1) +lisp-object+)
       (emit 'putstatic *this-class* g +lisp-object+)
-      (if *declared-inline*
+      (if *declare-inline*
           (setf saved-code *code*)
           (setf *static-code* *code*)))
-    (when *declared-inline*
+    (when *declare-inline*
       (setf *code* saved-code))
     g))
 



From ehuelsmann at common-lisp.net  Thu Oct 29 22:31:34 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 29 Oct 2009 18:31:34 -0400
Subject: [armedbear-cvs] r12234 - trunk/abcl/src/org/armedbear/lisp
Message-ID: 

Author: ehuelsmann
Date: Thu Oct 29 18:31:31 2009
New Revision: 12234

Log:
Don't create 2 fields to store/retrieve a single (cached!) value.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Lisp.java
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

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	Thu Oct 29 18:31:31 2009
@@ -2129,9 +2129,14 @@
   private static final Hashtable objectTable =
           new Hashtable();
 
+  public static final LispObject recall(String key)
+  {
+    return objectTable.remove(key);
+  }
+
   public static final LispObject recall(SimpleString key)
   {
-    return (LispObject) objectTable.remove(key.getStringValue());
+    return objectTable.remove(key.getStringValue());
   }
 
   // ### remember

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	Thu Oct 29 18:31:31 2009
@@ -2271,21 +2271,19 @@
 loading the object value into a field upon class-creation time.
 
 The field type of the object is specified by OBJ-REF."
-  (let ((key (symbol-name (gensym "OBJ"))))
+  (let ((g (symbol-name (gensym "OBJ"))))
     ;; fixme *declare-inline*?
-    (remember key obj)
-    (let* ((g1 (declare-string key))
-           (g2 (symbol-name (gensym "O2BJ"))))
-      (let* ((*code* *static-code*))
-        (declare-field g2 obj-ref +field-access-private+)
-        (emit 'getstatic *this-class* g1 +lisp-simple-string+)
-        (emit-invokestatic +lisp-class+ "recall"
-                           (list +lisp-simple-string+) +lisp-object+)
-        (when (and obj-class (string/= obj-class +lisp-object-class+))
-          (emit 'checkcast obj-class))
-        (emit 'putstatic *this-class* g2 obj-ref)
-        (setf *static-code* *code*)
-        g2))))
+    (remember g obj)
+    (let* ((*code* *static-code*))
+      (declare-field g obj-ref +field-access-private+)
+      (emit 'ldc (pool-string g))
+      (emit-invokestatic +lisp-class+ "recall"
+                         (list +java-string+) +lisp-object+)
+      (when (and obj-class (string/= obj-class +lisp-object-class+))
+        (emit 'checkcast obj-class))
+      (emit 'putstatic *this-class* g obj-ref)
+      (setf *static-code* *code*)
+      g)))
 
 (defun declare-lambda (obj)
   (let (saved-code



From mevenson at common-lisp.net  Fri Oct 30 12:45:46 2009
From: mevenson at common-lisp.net (Mark Evenson)
Date: Fri, 30 Oct 2009 08:45:46 -0400
Subject: [armedbear-cvs] r12235 - trunk/abcl
Message-ID: 

Author: mevenson
Date: Fri Oct 30 08:45:42 2009
New Revision: 12235

Log:
Make default action of Ant build to clean then compile.

The former default action was the 'help' target.  Now we invoke
'abcl.wrapper' which by default cleans intermediate files, and then
does the necessary steps to create an executable wrapper in either
'abcl' (UNIX) or 'abcl.in'.

To restore the incremental build behavior, set the
'abcl.incremental.build' property either on the command line via the
'-Dabcl.incremental.build=true' option or add the line 

abcl.incremental.build=true

into a top-level file named 'build.properties'.




Modified:
   trunk/abcl/build.xml

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Fri Oct 30 08:45:42 2009
@@ -1,6 +1,6 @@
 
 
+	 name="abcl-master" default="abcl.wrapper" basedir=".">
     Compiling, testing, and packaging Armed Bear Common Lisp
 
     
@@ -90,9 +90,16 @@
       
     
 
-    
+    
       Compiled ABCL with Java version: ${java.version}
     
+    
+    
+      Cleaning all intermediate compilation artifacts.
+      Setting 'abcl.build.incremental' enables incremental compilation.
+      
+    
+      
 
     
       



From ehuelsmann at common-lisp.net  Sat Oct 31 10:51:30 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Oct 2009 06:51:30 -0400
Subject: [armedbear-cvs] r12236 - trunk/abcl
Message-ID: 

Author: ehuelsmann
Date: Sat Oct 31 06:51:27 2009
New Revision: 12236

Log:
Update CHANGES.

Modified:
   trunk/abcl/CHANGES

Modified: trunk/abcl/CHANGES
==============================================================================
--- trunk/abcl/CHANGES	(original)
+++ trunk/abcl/CHANGES	Sat Oct 31 06:51:27 2009
@@ -4,9 +4,15 @@
 
 Features:
 
+  * Google App Engine example project "Hello world"
   * Support for loading FASLs from JAR files
   * Checking of init-arguments for MAKE-INSTANCE (CLOS)
   * Support for *INVOKE-DEBUGGER-HOOK* (to support SLIME)
+  * Reduced abcl.jar size (bytes and number of objects)
+  * Faster access to locally bound specials (compiler efficiency)
+  * Java property to print autoloading information: abcl.autoload.verbose
+  * Experimental: binary fasls
+  * Default Ant build target now "abcl.clean abcl.wrapper" (from abcl.help)
 
 
 Bugs fixed:
@@ -23,6 +29,12 @@
     and BLOCK/RETURN-FROM blocks (compiler and interpreter)
   * Correctly return 65k in char-code-limit (was 256, incorrectly)
   * Fixes to be able to run the BEYOND-ANSI tests (part of ANSI test suite)
+  * Compiler typo fix
+  * Implementation of mutex functionality moved to lisp from Java
+  * Functions handling #n= and #n# are now compiled
+  * Autoload cleanups
+  * System package creation cleaned up
+  * CHAR-CODE-LIMIT correctly reflects CHAR-CODE maximum return value
 
 
 Version 0.16.1



From ehuelsmann at common-lisp.net  Sat Oct 31 21:16:18 2009
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 31 Oct 2009 17:16:18 -0400
Subject: [armedbear-cvs] r12237 - trunk/abcl
Message-ID: 

Author: ehuelsmann
Date: Sat Oct 31 17:16:15 2009
New Revision: 12237

Log:
Update README.

Modified:
   trunk/abcl/README

Modified: trunk/abcl/README
==============================================================================
--- trunk/abcl/README	(original)
+++ trunk/abcl/README	Sat Oct 31 17:16:15 2009
@@ -32,6 +32,32 @@
 exception statement from your version.
 
 
+RUNNING FROM BINARY RELEASE
+===========================
+
+After you have downloaded a binary release archive, unzip or untar it
+into its own directory. To run ABCL directly from this directory, make
+sure Java (version 1.5 or up) is in your path. Then, type the following
+command:
+
+  $ java -jar abcl.jar
+
+Which should result output like the following:
+
+----------------
+Armed Bear Common Lisp 0.17.0
+Java 1.6.0_14 Sun Microsystems Inc.
+Java HotSpot(TM) Client VM
+Low-level initialization completed in 0.9 seconds.
+Startup completed in 2.294 seconds.
+Type ":help" for a list of available commands.
+CL-USER(1):
+----------------
+
+In order to build ABCL, you need the full SDK. However, in order to
+just run it (like the above), the JRE is enough.
+
+
 BUILDING
 ========
 
@@ -109,27 +135,28 @@
 
 A lot of (renewed) energy has been spent to make ABCL a compliant
 and practically useable Common Lisp implementation.  Because of this,
-ABCL 0.0.11 now fails only 47 out of 21702 tests in the ANSI CL test
+ABCL 0.17.0 now fails only 34 out of 21702 tests in the ANSI CL test
 suite.  Next to that, the fail count of the Maxima test suite has been
-reduced from over 1400 in 0.0.10 to little more than 600 in 0.0.11.
+reduced to only 3 - rounding errors.
 
 ABCL's CLOS does not handle on-the-fly redefinition of classes
-correctly, and in any event is intolerably slow. There is no support
-for the long form of DEFINE-METHOD-COMBINATION, and certain other
-required CLOS features are also missing. Enough CLOS is there to run
+correctly. Quite a bit of energy has been spent in versions 0.16.0 and
+0.17.0 to improve CLOS performance. There is no support for the long
+form of DEFINE-METHOD-COMBINATION, and certain other required CLOS
+features are also missing. Enough CLOS is there to run
 ASDF and CL-PPCRE, if you're in no hurry.
 
 There is no MOP worth mentioning.
 
-Since this is a early public release, there might be build
-problems as well as runtime bugs.
+Patches to address any of the issues mentioned above will be gladly
+accepted.
 
-Please report problems to the j-devel mailing list:
+Please report problems to the development mailing list:
 
-    armedbear-j-devel at lists.sourceforge.net
+    armedbear-devel at common-lisp.net
 
 Have fun!
 
 On behalf of all ABCL development team and contributors,
 Erik Huelsmann
-October 18, 2008
+October 31, 2009