From ehuelsmann at common-lisp.net Wed Apr 1 19:58:14 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 01 Apr 2009 15:58:14 -0400 Subject: [armedbear-cvs] r11722 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 1 15:58:11 2009 New Revision: 11722 Log: Make sure to create Fixnums when the LispInteger/Bignum created is in the Fixnum range. Note: After this commit, your .abcl files need to be recompiled as it makes the Bignum and Fixnum constructors 'private'. Modified: trunk/abcl/src/org/armedbear/lisp/Bignum.java trunk/abcl/src/org/armedbear/lisp/Fixnum.java trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java trunk/abcl/src/org/armedbear/lisp/JavaObject.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispInteger.java trunk/abcl/src/org/armedbear/lisp/RuntimeClass.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Bignum.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Bignum.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Bignum.java Wed Apr 1 15:58:11 2009 @@ -39,23 +39,40 @@ { public final BigInteger value; - public static Bignum getInstance(long l) { - return new Bignum(l); + private static BigInteger MOST_NEGATIVE_FIXNUM = + BigInteger.valueOf(Integer.MIN_VALUE); + private static BigInteger MOST_POSITIVE_FIXNUM = + BigInteger.valueOf(Integer.MAX_VALUE); + + public static LispInteger getInstance(long l) { + if (Integer.MIN_VALUE <= l && l <= Integer.MAX_VALUE) + return Fixnum.getInstance(l); + else + return new Bignum(l); } - public Bignum(long l) - { - value = BigInteger.valueOf(l); + public static LispInteger getInstance(BigInteger n) { + if (MOST_NEGATIVE_FIXNUM.compareTo(n) < 0 || + MOST_POSITIVE_FIXNUM.compareTo(n) > 0) + return new Bignum(n); + else + return Fixnum.getInstance(n.intValue()); } - public Bignum(BigInteger n) + public static LispInteger getInstance(String s, int radix) { + BigInteger value = new BigInteger(s, radix); + + return Bignum.getInstance(value); + } + + private Bignum(long l) { - value = n; + value = BigInteger.valueOf(l); } - public Bignum(String s, int radix) + private Bignum(BigInteger n) { - value = new BigInteger(s, radix); + value = n; } @Override Modified: trunk/abcl/src/org/armedbear/lisp/Fixnum.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Fixnum.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Fixnum.java Wed Apr 1 15:58:11 2009 @@ -252,9 +252,7 @@ { if (value >= 0) return this; - if (value > Integer.MIN_VALUE) - return Fixnum.getInstance(-value); - return new Bignum(-((long)Integer.MIN_VALUE)); + return LispInteger.getInstance(-(long)value); } @Override @@ -371,37 +369,25 @@ @Override public final LispObject incr() { - if (value < Integer.MAX_VALUE) - return Fixnum.getInstance(value + 1); - return new Bignum((long) value + 1); + return LispInteger.getInstance(1 + (long)value); } @Override public final LispObject decr() { - if (value > Integer.MIN_VALUE) - return Fixnum.getInstance(value - 1); - return new Bignum((long) value - 1); + return LispInteger.getInstance(-1 + (long)value); } @Override public LispObject negate() { - long result = 0L - value; - if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) - return Fixnum.getInstance((int)result); - else - return new Bignum(result); + return LispInteger.getInstance((-(long)value)); } @Override public LispObject add(int n) { - long result = (long) value + n; - if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) - return Fixnum.getInstance((int)result); - else - return new Bignum(result); + return LispInteger.getInstance((long) value + n); } @Override @@ -410,10 +396,7 @@ if (obj instanceof Fixnum) { long result = (long) value + ((Fixnum)obj).value; - if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) - return Fixnum.getInstance((int)result); - else - return new Bignum(result); + return LispInteger.getInstance(result); } if (obj instanceof Bignum) return number(getBigInteger().add(((Bignum)obj).value)); @@ -439,11 +422,7 @@ @Override public LispObject subtract(int n) { - long result = (long) value - n; - if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) - return Fixnum.getInstance((int)result); - else - return new Bignum(result); + return LispInteger.getInstance((long)value - n); } @Override @@ -478,10 +457,7 @@ public LispObject multiplyBy(int n) { long result = (long) value * n; - if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) - return Fixnum.getInstance((int)result); - else - return new Bignum(result); + return LispInteger.getInstance(result); } @Override @@ -490,10 +466,7 @@ if (obj instanceof Fixnum) { long result = (long) value * ((Fixnum)obj).value; - if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) - return Fixnum.getInstance((int)result); - else - return new Bignum(result); + return LispInteger.getInstance(result); } if (obj instanceof Bignum) return number(getBigInteger().multiply(((Bignum)obj).value)); @@ -838,10 +811,7 @@ if (shift <= 32) { n = n << shift; - if (n >= Integer.MIN_VALUE && n <= Integer.MAX_VALUE) - return Fixnum.getInstance((int)n); - else - return new Bignum(n); + return LispInteger.getInstance(n); } // BigInteger.shiftLeft() succumbs to a stack overflow if shift // is Integer.MIN_VALUE, so... @@ -961,7 +931,7 @@ BigInteger y = Bignum.getValue(obj); if (y.compareTo (BigInteger.ZERO) < 0) - return (Fixnum.getInstance(1)).divideBy(this.pow(new Bignum(y.negate()))); + return (Fixnum.getInstance(1)).divideBy(this.pow(Bignum.getInstance(y.negate()))); if (y.compareTo(BigInteger.ZERO) == 0) // No need to test base here; CLHS says 0^0 == 1. @@ -987,7 +957,7 @@ y = y.shiftLeft(1); } - return new Bignum(xy); + return Bignum.getInstance(xy); } @Override Modified: trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java Wed Apr 1 15:58:11 2009 @@ -154,12 +154,12 @@ if (arg instanceof SingleFloat) { int bits = Float.floatToIntBits(((SingleFloat)arg).value); BigInteger big = BigInteger.valueOf(bits >> 1); - return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO)); + return Bignum.getInstance(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO)); } if (arg instanceof DoubleFloat) { long bits = Double.doubleToLongBits(((DoubleFloat)arg).value); BigInteger big = BigInteger.valueOf(bits >> 1); - return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO)); + return Bignum.getInstance(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO)); } return type_error(arg, Symbol.FLOAT); } Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Wed Apr 1 15:58:11 2009 @@ -134,7 +134,7 @@ return LispInteger.getInstance(((Long)obj).longValue()); if (obj instanceof BigInteger) - return new Bignum((BigInteger)obj); + return Bignum.getInstance((BigInteger)obj); if (obj instanceof Short) return Fixnum.getInstance(((Short)obj).shortValue()); 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 Apr 1 15:58:11 2009 @@ -881,7 +881,7 @@ if (n >= Integer.MIN_VALUE && n <= Integer.MAX_VALUE) return Fixnum.getInstance((int)n); else - return new Bignum(n); + return Bignum.getInstance(n); } private static final BigInteger INT_MIN = BigInteger.valueOf(Integer.MIN_VALUE); @@ -915,7 +915,7 @@ if (n.compareTo(INT_MIN) >= 0 && n.compareTo(INT_MAX) <= 0) return Fixnum.getInstance(n.intValue()); else - return new Bignum(n); + return Bignum.getInstance(n); } public static final int mod(int number, int divisor) @@ -1219,7 +1219,7 @@ list(Symbol.UNSIGNED_BYTE, Fixnum.constants[32]); public static final LispObject UNSIGNED_BYTE_32_MAX_VALUE = - new Bignum(4294967296L); + Bignum.getInstance(4294967296L); public static final LispObject getUpgradedArrayElementType(LispObject type) throws ConditionThrowable @@ -2088,8 +2088,8 @@ { Symbol.MOST_POSITIVE_FIXNUM.initializeConstant(Fixnum.getInstance(Integer.MAX_VALUE)); Symbol.MOST_NEGATIVE_FIXNUM.initializeConstant(Fixnum.getInstance(Integer.MIN_VALUE)); - Symbol.MOST_POSITIVE_JAVA_LONG.initializeConstant(new Bignum(Long.MAX_VALUE)); - Symbol.MOST_NEGATIVE_JAVA_LONG.initializeConstant(new Bignum(Long.MIN_VALUE)); + Symbol.MOST_POSITIVE_JAVA_LONG.initializeConstant(Bignum.getInstance(Long.MAX_VALUE)); + Symbol.MOST_NEGATIVE_JAVA_LONG.initializeConstant(Bignum.getInstance(Long.MIN_VALUE)); } public static void exit(int status) Modified: trunk/abcl/src/org/armedbear/lisp/LispInteger.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispInteger.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispInteger.java Wed Apr 1 15:58:11 2009 @@ -43,7 +43,7 @@ if (Integer.MIN_VALUE <= l && l <= Integer.MAX_VALUE) return Fixnum.getInstance((int)l); else - return new Bignum(l); + return Bignum.getInstance(l); } public static LispInteger getInstance(int i) { Modified: trunk/abcl/src/org/armedbear/lisp/RuntimeClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/RuntimeClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/RuntimeClass.java Wed Apr 1 15:58:11 2009 @@ -169,9 +169,9 @@ return Fixnum.getInstance(i); } - public static final Bignum makeLispObject(long i) throws ConditionThrowable + public static final LispInteger makeLispObject(long i) throws ConditionThrowable { - return new Bignum(i); + return Bignum.getInstance(i); } public static final SingleFloat makeLispObject(float i) 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 Apr 1 15:58:11 2009 @@ -1356,7 +1356,7 @@ // parseInt() failed. try { - return new Bignum(token, radix); + return Bignum.getInstance(token, radix); } catch (NumberFormatException e) {} // Not a number. @@ -1493,7 +1493,7 @@ // parseInt() failed. try { - return new Bignum(s, radix); + return Bignum.getInstance(s, radix); } catch (NumberFormatException e) {} // Not a number. @@ -1522,7 +1522,7 @@ // parseInt() failed. try { - return new Bignum(s, radix); + return Bignum.getInstance(s, radix); } catch (NumberFormatException e) {} // Not a number. 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 Apr 1 15:58:11 2009 @@ -2200,21 +2200,20 @@ (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym)))) (let ((*code* *static-code*)) (declare-field g +lisp-integer+) - (emit 'new +lisp-bignum-class+) - (emit 'dup) (cond ((<= most-negative-java-long n most-positive-java-long) ;; (setf g (format nil "BIGNUM_~A~D" ;; (if (minusp n) "MINUS_" "") ;; (abs n))) (emit 'ldc2_w (pool-long n)) - (emit-invokespecial-init +lisp-bignum-class+ '("J"))) + (emit-invokestatic +lisp-bignum-class+ "getInstance" + '("J") +lisp-integer+)) (t (let* ((*print-base* 10) (s (with-output-to-string (stream) (dump-form n stream)))) (emit 'ldc (pool-string s)) (emit-push-constant-int 10) - (emit-invokespecial-init +lisp-bignum-class+ - (list +java-string+ "I"))))) + (emit-invokestatic +lisp-bignum-class+ "getInstance" + (list +java-string+ "I") +lisp-integer+)))) (emit 'putstatic *this-class* g +lisp-integer+) (setf *static-code* *code*)) (setf (gethash n ht) g))) From ehuelsmann at common-lisp.net Fri Apr 3 19:41:30 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 03 Apr 2009 15:41:30 -0400 Subject: [armedbear-cvs] r11723 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Apr 3 15:41:28 2009 New Revision: 11723 Log: Fix [interpreted mode] RESTART-CASE.{29,30,31}. When expanding macros inside a macro, use the current expansion environment to make sure all local macro definitions get expanded too. Modified: trunk/abcl/src/org/armedbear/lisp/restart.lisp Modified: trunk/abcl/src/org/armedbear/lisp/restart.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/restart.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/restart.lisp Fri Apr 3 15:41:28 2009 @@ -163,8 +163,8 @@ ;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a ;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the ;; indicated restarts with the condition to be signaled." -(defun munge-restart-case-expression (expression) - (let ((exp (macroexpand expression))) +(defun munge-restart-case-expression (expression env) + (let ((exp (macroexpand expression env))) (if (consp exp) (let* ((name (car exp)) (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) @@ -186,7 +186,7 @@ expression)) expression))) -(defmacro restart-case (expression &body clauses) +(defmacro restart-case (expression &body clauses &environment env) (let ((block-tag (gensym)) (temp-var (gensym)) (data @@ -215,7 +215,8 @@ (go ,tag)) , at keys))) data) - (return-from ,block-tag ,(munge-restart-case-expression expression))) + (return-from ,block-tag + ,(munge-restart-case-expression expression env))) ,@(mapcan #'(lambda (datum) (let ((tag (nth 1 datum)) (bvl (nth 3 datum)) From ehuelsmann at common-lisp.net Fri Apr 3 20:17:37 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 03 Apr 2009 16:17:37 -0400 Subject: [armedbear-cvs] r11724 - trunk/abcl/src/org/armedbear/lisp/scripting Message-ID: Author: ehuelsmann Date: Fri Apr 3 16:17:36 2009 New Revision: 11724 Log: Make the scripting engine use the Bignum factory instead of the (now private) constructor. Patch by: Douglas Miles (logicmoo at gmail dot com) Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Fri Apr 3 16:17:36 2009 @@ -311,9 +311,9 @@ } else if(javaObject instanceof Short) { return Fixnum.getInstance(((Short)javaObject).shortValue()); } else if(javaObject instanceof Long) { - return new Bignum((Long)javaObject); + return Bignum.getInstance((Long)javaObject); } else if(javaObject instanceof BigInteger) { - return new Bignum((BigInteger) javaObject); + return Bignum.getInstance((BigInteger) javaObject); } else if(javaObject instanceof Float) { return new SingleFloat(((Float)javaObject).floatValue()); } else if(javaObject instanceof Double) { From ehuelsmann at common-lisp.net Fri Apr 3 21:17:54 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 03 Apr 2009 17:17:54 -0400 Subject: [armedbear-cvs] r11725 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Apr 3 17:17:53 2009 New Revision: 11725 Log: Code audited for the use of MACROEXPAND without an environment. Also, it turns out the precompiler used to work around the previously fixed issue in RESTART-CASE by special-casing its expansion. Remove that special casing. 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 Fri Apr 3 17:17:53 2009 @@ -421,13 +421,13 @@ (defun precompile-dolist (form) (if *in-jvm-compile* - (precompile1 (macroexpand form)) + (precompile1 (macroexpand form *compile-file-environment*)) (cons 'DOLIST (cons (mapcar #'precompile1 (cadr form)) (mapcar #'precompile1 (cddr form)))))) (defun precompile-dotimes (form) (if *in-jvm-compile* - (precompile1 (macroexpand form)) + (precompile1 (macroexpand form *compile-file-environment*)) (cons 'DOTIMES (cons (mapcar #'precompile1 (cadr form)) (mapcar #'precompile1 (cddr form)))))) @@ -463,7 +463,7 @@ (defun precompile-do/do* (form) (if *in-jvm-compile* - (precompile1 (macroexpand form)) + (precompile1 (macroexpand form *compile-file-environment*)) (list* (car form) (precompile-do/do*-vars (cadr form)) (precompile-do/do*-end-form (caddr form)) @@ -646,15 +646,6 @@ (parse-body (cddr form) nil) `(locally , at decls ,@(mapcar #'precompile1 body))))) -;; "If the restartable-form is a list whose car is any of the symbols SIGNAL, -;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a -;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the -;; indicated restarts with the condition to be signaled." So we need to -;; precompile the restartable form before macroexpanding RESTART-CASE. -(defun precompile-restart-case (form) - (let ((new-form (list* 'RESTART-CASE (precompile1 (cadr form)) (cddr form)))) - (precompile1 (macroexpand new-form sys:*compile-file-environment*)))) - (defun precompile-symbol-macrolet (form) (let ((*local-variables* *local-variables*) (*compile-file-environment* @@ -746,7 +737,7 @@ (defun precompile-case (form) (if *in-jvm-compile* - (precompile1 (macroexpand form)) + (precompile1 (macroexpand form *compile-file-environment*)) (let* ((keyform (cadr form)) (clauses (cddr form)) (result (list (precompile1 keyform)))) @@ -761,7 +752,7 @@ (defun precompile-cond (form) (if *in-jvm-compile* - (precompile1 (macroexpand form)) + (precompile1 (macroexpand form *compile-file-environment*)) (let ((clauses (cdr form)) (result nil)) (dolist (clause clauses) @@ -866,12 +857,12 @@ (defun precompile-when (form) (if *in-jvm-compile* - (precompile1 (macroexpand form)) + (precompile1 (macroexpand form *compile-file-environment*)) (precompile-cons form))) (defun precompile-unless (form) (if *in-jvm-compile* - (precompile1 (macroexpand form)) + (precompile1 (macroexpand form *compile-file-environment*)) (precompile-cons form))) ;; MULTIPLE-VALUE-BIND is handled explicitly by the JVM compiler. @@ -890,12 +881,12 @@ (defun precompile-nth-value (form) (if *in-jvm-compile* - (precompile1 (macroexpand form)) + (precompile1 (macroexpand form *compile-file-environment*)) form)) (defun precompile-return (form) (if *in-jvm-compile* - (precompile1 (macroexpand form)) + (precompile1 (macroexpand form *compile-file-environment*)) (list 'RETURN (precompile1 (cadr form))))) (defun precompile-return-from (form) @@ -981,7 +972,6 @@ PROGV PSETF PSETQ - RESTART-CASE RETURN RETURN-FROM SETF From ehuelsmann at common-lisp.net Fri Apr 3 21:52:59 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 03 Apr 2009 17:52:59 -0400 Subject: [armedbear-cvs] r11726 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Apr 3 17:52:58 2009 New Revision: 11726 Log: Fix class dependency issue. The current code works on Sun, however with this change we should work on GCJ and other JVMs too. Patch by: Douglas Miles (logicmoo at gmail dot com) Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Nil.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 Apr 3 17:52:58 2009 @@ -78,9 +78,7 @@ Packages.createPackage("JAVA"); // ### nil - // Constructing NIL forces the Symbol class to be loaded (since Nil extends - // Symbol). - public static final LispObject NIL = new Nil(PACKAGE_CL); + public static final LispObject NIL = Nil.NIL; // We need NIL before we can call usePackage(). static Modified: trunk/abcl/src/org/armedbear/lisp/Nil.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Nil.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Nil.java Fri Apr 3 17:52:58 2009 @@ -35,6 +35,8 @@ public final class Nil extends Symbol { + final static Nil NIL = new Nil(PACKAGE_CL); + public Nil(Package pkg) { super("NIL", pkg); From ehuelsmann at common-lisp.net Sat Apr 4 19:18:09 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 04 Apr 2009 15:18:09 -0400 Subject: [armedbear-cvs] r11727 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Apr 4 15:18:06 2009 New Revision: 11727 Log: Add CHANGES file, summarizing changes per release. Added: trunk/abcl/CHANGES (contents, props changed) Added: trunk/abcl/CHANGES ============================================================================== --- (empty file) +++ trunk/abcl/CHANGES Sat Apr 4 15:18:06 2009 @@ -0,0 +1,52 @@ +Version 0.14.0 +(?? Apr, 2009) +svn://common-lisp.net/project/armedbear/svn/tags/0.14.0/abcl + + Summary of changes: + * Increased clarity on licensing (Classpath exception + mentioned in COPYING, removed LICENSE) + * Resolved infinite recursion on TRACEing the compiler + * Changes on the lisp based build system for parity with Ant + * Fixed interpreter creation in Java Scripting + * libabcl.so no longer created; it was solely about installing + a SIGINT handler. Libraries should not do that. + * boxing of LispObject descendants in JCALL/JCALL-RAW fixed + * OpenBSD and NetBSD platform detection + * fixed special bindings restores in compiled code for + MULTIPLE-VALUE-BIND/LET/LET*/PROGV and function bodies + * introduced variadic list() function to replace list1() ... list9() + * fix return value type of ACOS with complex argument + * fixed precision of multiplication of complex values + * fixed use of COMPILE inside file compilation (i.e. COMPILE-FILE) + * fix expansion of macros inside RESTART-CASE + (fixes RESTART-CASE ANSI failures) + * fix macroexpansion in the precompiler + * Fixnum and Bignum now use a static factory method; + constructors are now private -> increases chances of numbers + being EQ + + +Version 0.13.0 +(28 Feb, 2009) +svn://common-lisp.net/project/armedbear/svn/tags/0.13.0/abcl + + Summary of changes: + * Separated J and ABCL into two trees + * Many many compiler code cleanups + * NetBeans project files + * Support for CDR6 (See http://cdr.eurolisp.org/document/6/) + * More efficient code emission in the compiler + * Ant build targets for testing (abcl.test) + * Use ConcurrentHashMap to store the lisp threads for increased performance + * Fix adjustability of expressly adjustable arrays (ticket #28) + * Fix calculation of upperbound on ASH in the compiler + (don't calculate numbers too big, instead, return '*') + * Introduce LispInteger as the super type of Bignum and Fixnum + * Boxing/unboxing for SingleFloat and DoubleFloat values, + inclusive of unboxed calculations + * Fixed URL decoding bug in loadCompiledFunction (use java.net.URLDecoder) + * Fixed line number counting + * Inlining of simple calculations (+/-/*) + * All static fields declared 'final' + * Add support for java.lang.Long based on Bignum to our FFI + From ehuelsmann at common-lisp.net Sat Apr 4 21:14:18 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 04 Apr 2009 17:14:18 -0400 Subject: [armedbear-cvs] r11728 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Apr 4 17:14:17 2009 New Revision: 11728 Log: java.lang.Math has the 'log10()' function since 1.5. Our minimal target is 1.5, so, stop working around its absense. Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MathFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Sat Apr 4 17:14:17 2009 @@ -632,17 +632,6 @@ return type_error(obj, Symbol.NUMBER); } - private static Method log10Method = null; - static { - try { - log10Method = Class.forName("java.lang.Math") - .getMethod("log10", new Class[] { Double.TYPE }); - } - catch (Throwable t) { - Debug.trace(t); - } - } - // ### log private static final Primitive LOG = new Primitive("log", "number &optional base") @@ -656,19 +645,16 @@ public LispObject execute(LispObject number, LispObject base) throws ConditionThrowable { - if (number.realp() && !number.minusp() && base.isEqualTo(Fixnum.getInstance(10))) { - double d = DoubleFloat.coerceToFloat(number).value; + if (number.realp() && !number.minusp() + && base.isEqualTo(Fixnum.getInstance(10))) { try { - if (log10Method != null) { - Object[] args; - args = new Object[1]; - args[0] = new Double(d); - Double result = (Double) log10Method.invoke(null, args); - if (number instanceof DoubleFloat || base instanceof DoubleFloat) - return new DoubleFloat(result.doubleValue()); - else - return new SingleFloat((float)result.doubleValue()); - } + double d = + Math.log10(DoubleFloat.coerceToFloat(number).value); + if (number instanceof DoubleFloat + || base instanceof DoubleFloat) + return new DoubleFloat(d); + else + return new SingleFloat((float)d); } catch (Throwable t) { Debug.trace(t); From ehuelsmann at common-lisp.net Sat Apr 4 21:57:58 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 04 Apr 2009 17:57:58 -0400 Subject: [armedbear-cvs] r11729 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Apr 4 17:57:58 2009 New Revision: 11729 Log: Fix EXPT with a Bignum exponent. At the same time, simplify EXPT and add some documentation. Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MathFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Sat Apr 4 17:57:58 2009 @@ -747,60 +747,27 @@ } if (base.zerop()) return base; - if (power instanceof Fixnum) { - if (base.rationalp()) - return intexp(base, power); - LispObject result; - if (base instanceof SingleFloat) - result = SingleFloat.ONE; - else if (base instanceof DoubleFloat) - result = DoubleFloat.ONE; - else - // base is complex - result = Fixnum.ONE; - int pow = ((Fixnum)power).value; - if (pow > 0) { - LispObject term = base; - while (pow != 0) { - if ((pow & 1) == 1) - result = result.multiplyBy(term); - - term = term.multiplyBy(term); - pow = pow >> 1; - } - } else if (pow < 0) { - LispObject term = base; - pow = -pow; - while (pow != 0) { - if ((pow & 1) == 1) - result = result.divideBy(term); - - term = term.multiplyBy(term); - pow = pow >> 1; - } - } - if (TRAP_OVERFLOW) { - if (result instanceof SingleFloat) - if (Float.isInfinite(((SingleFloat)result).value)) - return error(new FloatingPointOverflow(NIL)); - if (result instanceof DoubleFloat) - if (Double.isInfinite(((DoubleFloat)result).value)) - return error(new FloatingPointOverflow(NIL)); - } - if (TRAP_UNDERFLOW) { - if (result.zerop()) - return error(new FloatingPointUnderflow(NIL)); - } - return result; + if (base.isEqualTo(1)) + return base; + + if ((power instanceof Fixnum + || power instanceof Bignum) + && (base.rationalp() + || (base instanceof Complex + && ((Complex)base).realpart.rationalp()))) { + // exact math version + return intexp(base, power); } - if (base instanceof Fixnum && power instanceof Bignum) - return ((Fixnum)base).pow(power); + // for anything not a rational or complex rational, use + // float approximation. if (base instanceof Complex || power instanceof Complex) return exp(power.multiplyBy(log(base))); final double x; // base final double y; // power if (base instanceof Fixnum) x = ((Fixnum)base).value; + else if (base instanceof Bignum) + x = ((Bignum)base).doubleValue(); else if (base instanceof Ratio) x = ((Ratio)base).doubleValue(); else if (base instanceof SingleFloat) @@ -810,7 +777,12 @@ else return error(new LispError("EXPT: unsupported case: base is of type " + base.typeOf().writeToString())); - if (power instanceof Ratio) + + if (power instanceof Fixnum) + y = ((Fixnum)power).value; + else if (power instanceof Bignum) + y = ((Bignum)power).doubleValue(); + else if (power instanceof Ratio) y = ((Ratio)power).doubleValue(); else if (power instanceof SingleFloat) y = ((SingleFloat)power).value; @@ -826,30 +798,76 @@ double realPart = r * Math.cos(y * Math.PI); double imagPart = r * Math.sin(y * Math.PI); if (base instanceof DoubleFloat || power instanceof DoubleFloat) - return Complex.getInstance(new DoubleFloat(realPart), - new DoubleFloat(imagPart)); + return Complex + .getInstance(OverUnderFlowCheck(new DoubleFloat(realPart)), + OverUnderFlowCheck(new DoubleFloat(imagPart))); else - return Complex.getInstance(new SingleFloat((float)realPart), - new SingleFloat((float)imagPart)); + return Complex + .getInstance(OverUnderFlowCheck(new SingleFloat((float)realPart)), + OverUnderFlowCheck(new SingleFloat((float)imagPart))); } } if (base instanceof DoubleFloat || power instanceof DoubleFloat) - return new DoubleFloat(r); + return OverUnderFlowCheck(new DoubleFloat(r)); else - return new SingleFloat((float)r); + return OverUnderFlowCheck(new SingleFloat((float)r)); } }; + /** Checks number for over- or underflow values. + * + * @param number + * @return number or signals an appropriate error + * @throws org.armedbear.lisp.ConditionThrowable + */ + private final static LispObject OverUnderFlowCheck(LispObject number) + throws ConditionThrowable + { + if (number instanceof Complex) { + OverUnderFlowCheck(((Complex)number).realpart); + OverUnderFlowCheck(((Complex)number).imagpart); + return number; + } + + if (TRAP_OVERFLOW) { + if (number instanceof SingleFloat) + if (Float.isInfinite(((SingleFloat)number).value)) + return error(new FloatingPointOverflow(NIL)); + if (number instanceof DoubleFloat) + if (Double.isInfinite(((DoubleFloat)number).value)) + return error(new FloatingPointOverflow(NIL)); + } + if (TRAP_UNDERFLOW) { + if (number.zerop()) + return error(new FloatingPointUnderflow(NIL)); + } + return number; + } + // Adapted from SBCL. + /** Return the exponent of base taken to the integer exponent power + * + * @param base A value of any type + * @param power An integer (fixnum or bignum) value + * @throws org.armedbear.lisp.ConditionThrowable + */ private static final LispObject intexp(LispObject base, LispObject power) throws ConditionThrowable { + if (power.isEqualTo(0)) + return Fixnum.ONE; + if (base.isEqualTo(1)) + return base; + if (base.isEqualTo(0)) + return base; + if (power.minusp()) { power = Fixnum.ZERO.subtract(power); return Fixnum.ONE.divideBy(intexp(base, power)); } if (base.eql(Fixnum.TWO)) return Fixnum.ONE.ash(power); + LispObject nextn = power.ash(Fixnum.MINUS_ONE); LispObject total; if (power.oddp()) @@ -860,10 +878,10 @@ if (nextn.zerop()) return total; base = base.multiplyBy(base); - power = nextn; - nextn = power.ash(Fixnum.MINUS_ONE); - if (power.oddp()) + + if (nextn.oddp()) total = base.multiplyBy(total); + nextn = nextn.ash(Fixnum.MINUS_ONE); } } } From ehuelsmann at common-lisp.net Sat Apr 4 22:16:54 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 04 Apr 2009 18:16:54 -0400 Subject: [armedbear-cvs] r11730 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Apr 4 18:16:53 2009 New Revision: 11730 Log: No longer work around absense of Math.{sinh(),cosh(),tanh()}; their initial appearance is in 1.5, our minimum target. Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MathFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Sat Apr 4 18:16:53 2009 @@ -33,8 +33,6 @@ package org.armedbear.lisp; -import java.lang.reflect.Method; - public final class MathFunctions extends Lisp { // ### sin @@ -259,17 +257,6 @@ } }; - private static Method sinhMethod = null; - static { - try { - sinhMethod = Class.forName("java.lang.Math") - .getMethod("sinh", new Class[] { Double.TYPE }); - } - catch (Throwable t) { - Debug.trace(t); - } - } - private static LispObject sinh(LispObject arg) throws ConditionThrowable { if (arg instanceof Complex) { @@ -280,13 +267,8 @@ } if (arg instanceof SingleFloat) { try { - if (sinhMethod != null) { - Object[] args; - args = new Object[1]; - args[0] = new Double(((SingleFloat)arg).value); - Double d = (Double) sinhMethod.invoke(null, args); - return new SingleFloat((float)d.doubleValue()); - } + double d = Math.sinh(((SingleFloat)arg).value); + return new SingleFloat((float)d); } catch (Throwable t) { Debug.trace(t); @@ -294,13 +276,8 @@ } } else if (arg instanceof DoubleFloat) { try { - if (sinhMethod != null) { - Object[] args; - args = new Object[1]; - args[0] = new Double(((DoubleFloat)arg).value); - Double d = (Double) sinhMethod.invoke(null, args); - return new DoubleFloat(d.doubleValue()); - } + double d = Math.sinh(((DoubleFloat)arg).value); + return new DoubleFloat(d); } catch (Throwable t) { Debug.trace(t); @@ -330,17 +307,6 @@ } }; - private static Method coshMethod = null; - static { - try { - coshMethod = Class.forName("java.lang.Math") - .getMethod("cosh", new Class[] { Double.TYPE }); - } - catch (Throwable t) { - Debug.trace(t); - } - } - private static LispObject cosh(LispObject arg) throws ConditionThrowable { if (arg instanceof Complex) { @@ -351,13 +317,8 @@ } if (arg instanceof SingleFloat) { try { - if (coshMethod != null) { - Object[] args; - args = new Object[1]; - args[0] = new Double(((SingleFloat)arg).value); - Double d = (Double) coshMethod.invoke(null, args); - return new SingleFloat((float)d.doubleValue()); - } + double d = Math.cosh(((SingleFloat)arg).value); + return new SingleFloat((float)d); } catch (Throwable t) { Debug.trace(t); @@ -365,13 +326,8 @@ } } else if (arg instanceof DoubleFloat) { try { - if (coshMethod != null) { - Object[] args; - args = new Object[1]; - args[0] = new Double(((DoubleFloat)arg).value); - Double d = (Double) coshMethod.invoke(null, args); - return new DoubleFloat(d.doubleValue()); - } + double d = Math.cosh(((DoubleFloat)arg).value); + return new DoubleFloat(d); } catch (Throwable t) { Debug.trace(t); @@ -391,17 +347,6 @@ return result; } - private static Method tanhMethod = null; - static { - try { - tanhMethod = Class.forName("java.lang.Math") - .getMethod("tanh", new Class[] { Double.TYPE }); - } - catch (Throwable t) { - Debug.trace(t); - } - } - // ### tanh private static final Primitive TANH = new Primitive("tanh", "number") { @@ -410,13 +355,8 @@ { if (arg instanceof SingleFloat) { try { - if (tanhMethod != null) { - Object[] args; - args = new Object[1]; - args[0] = new Double(((SingleFloat)arg).value); - Double d = (Double) tanhMethod.invoke(null, args); - return new SingleFloat((float)d.doubleValue()); - } + double d = Math.tanh(((SingleFloat)arg).value); + return new SingleFloat((float)d); } catch (Throwable t) { Debug.trace(t); @@ -424,13 +364,8 @@ } } else if (arg instanceof DoubleFloat) { try { - if (tanhMethod != null) { - Object[] args; - args = new Object[1]; - args[0] = new Double(((DoubleFloat)arg).value); - Double d = (Double) tanhMethod.invoke(null, args); - return new DoubleFloat(d.doubleValue()); - } + double d = Math.tanh(((DoubleFloat)arg).value); + return new DoubleFloat(d); } catch (Throwable t) { Debug.trace(t); From ehuelsmann at common-lisp.net Sat Apr 4 22:22:07 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 04 Apr 2009 18:22:07 -0400 Subject: [armedbear-cvs] r11731 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Apr 4 18:22:06 2009 New Revision: 11731 Log: Share code already abstracted out elsewhere (use OverUnderFlowCheck()). Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MathFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Sat Apr 4 18:22:06 2009 @@ -510,18 +510,10 @@ if (arg.realp()) { if (arg instanceof DoubleFloat) { double d = Math.pow(Math.E, ((DoubleFloat)arg).value); - if (TRAP_OVERFLOW && Double.isInfinite(d)) - return error(new FloatingPointOverflow(NIL)); - if (d == 0 && TRAP_UNDERFLOW) - return error(new FloatingPointUnderflow(NIL)); - return new DoubleFloat(d); + return OverUnderFlowCheck(new DoubleFloat(d)); } else { float f = (float) Math.pow(Math.E, SingleFloat.coerceToFloat(arg).value); - if (TRAP_OVERFLOW && Float.isInfinite(f)) - return error(new FloatingPointOverflow(NIL)); - if (f == 0 && TRAP_UNDERFLOW) - return error(new FloatingPointUnderflow(NIL)); - return new SingleFloat(f); + return OverUnderFlowCheck(new SingleFloat(f)); } } if (arg instanceof Complex) { From ehuelsmann at common-lisp.net Sun Apr 5 05:57:45 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 01:57:45 -0400 Subject: [armedbear-cvs] r11732 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun Apr 5 01:57:42 2009 New Revision: 11732 Log: Update CHANGES with last-nights commits. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Apr 5 01:57:42 2009 @@ -24,6 +24,7 @@ * Fixnum and Bignum now use a static factory method; constructors are now private -> increases chances of numbers being EQ + * Code cleanup in EXPT to fix (EXPT ) Version 0.13.0 From ehuelsmann at common-lisp.net Sun Apr 5 06:00:47 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 02:00:47 -0400 Subject: [armedbear-cvs] r11733 - branches/0.14.x Message-ID: Author: ehuelsmann Date: Sun Apr 5 02:00:47 2009 New Revision: 11733 Log: Branch 0.14.x in preparation of the 0.14.0 relaese. Added: branches/0.14.x/ - copied from r11732, /trunk/ From ehuelsmann at common-lisp.net Sun Apr 5 06:03:27 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 02:03:27 -0400 Subject: [armedbear-cvs] r11734 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 5 02:03:26 2009 New Revision: 11734 Log: Update version number on trunk now that 0.14.x is on a branch. Modified: trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Sun Apr 5 02:03:26 2009 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.14.0-dev"; + return "0.15.0-dev"; } } From ehuelsmann at common-lisp.net Sun Apr 5 06:04:26 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 02:04:26 -0400 Subject: [armedbear-cvs] r11735 - in branches: 0.12.x 0.13.x Message-ID: Author: ehuelsmann Date: Sun Apr 5 02:04:26 2009 New Revision: 11735 Log: Delete release branches of releases no longer supported. Removed: branches/0.12.x/ branches/0.13.x/ From ehuelsmann at common-lisp.net Sun Apr 5 06:20:52 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 02:20:52 -0400 Subject: [armedbear-cvs] r11736 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun Apr 5 02:20:51 2009 New Revision: 11736 Log: Update release date of 0.14.0. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Apr 5 02:20:51 2009 @@ -1,5 +1,5 @@ Version 0.14.0 -(?? Apr, 2009) +(5 Apr, 2009) svn://common-lisp.net/project/armedbear/svn/tags/0.14.0/abcl Summary of changes: From ehuelsmann at common-lisp.net Sun Apr 5 06:21:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 02:21:02 -0400 Subject: [armedbear-cvs] r11737 - branches/0.14.x/abcl Message-ID: Author: ehuelsmann Date: Sun Apr 5 02:21:01 2009 New Revision: 11737 Log: Update release date of 0.14.0. Modified: branches/0.14.x/abcl/CHANGES Modified: branches/0.14.x/abcl/CHANGES ============================================================================== --- branches/0.14.x/abcl/CHANGES (original) +++ branches/0.14.x/abcl/CHANGES Sun Apr 5 02:21:01 2009 @@ -1,5 +1,5 @@ Version 0.14.0 -(?? Apr, 2009) +(5 Apr, 2009) svn://common-lisp.net/project/armedbear/svn/tags/0.14.0/abcl Summary of changes: From ehuelsmann at common-lisp.net Sun Apr 5 06:22:59 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 02:22:59 -0400 Subject: [armedbear-cvs] r11738 - in tags/0.14.0: . abcl abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 5 02:22:58 2009 New Revision: 11738 Log: Create 0.14.0 release tag. Added: tags/0.14.0/ - copied from r11735, /branches/0.14.x/ tags/0.14.0/abcl/CHANGES - copied unchanged from r11737, /branches/0.14.x/abcl/CHANGES Modified: tags/0.14.0/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.14.0/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.14.0/abcl/src/org/armedbear/lisp/Version.java Sun Apr 5 02:22:58 2009 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.14.0-dev"; + return "0.14.0"; } } From ehuelsmann at common-lisp.net Sun Apr 5 06:23:51 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 02:23:51 -0400 Subject: [armedbear-cvs] r11739 - branches/0.14.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 5 02:23:50 2009 New Revision: 11739 Log: Update version number in release branch to 0.14.1-dev. Modified: branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java Sun Apr 5 02:23:50 2009 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.14.0-dev"; + return "0.14.1-dev"; } } From ehuelsmann at common-lisp.net Sun Apr 5 21:01:46 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 17:01:46 -0400 Subject: [armedbear-cvs] r11740 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun Apr 5 17:01:43 2009 New Revision: 11740 Log: Fix tarbal creation. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sun Apr 5 17:01:43 2009 @@ -372,6 +372,7 @@ + @@ -392,6 +393,7 @@ description="Additional includes in the source distribution relative to source root"> + From ehuelsmann at common-lisp.net Sun Apr 5 21:08:28 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 17:08:28 -0400 Subject: [armedbear-cvs] r11741 - branches/0.14.x/abcl Message-ID: Author: ehuelsmann Date: Sun Apr 5 17:08:27 2009 New Revision: 11741 Log: Backport r11740. Modified: branches/0.14.x/abcl/build.xml Modified: branches/0.14.x/abcl/build.xml ============================================================================== --- branches/0.14.x/abcl/build.xml (original) +++ branches/0.14.x/abcl/build.xml Sun Apr 5 17:08:27 2009 @@ -372,6 +372,7 @@ + @@ -392,6 +393,7 @@ description="Additional includes in the source distribution relative to source root"> + From ehuelsmann at common-lisp.net Sun Apr 5 21:12:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 17:12:02 -0400 Subject: [armedbear-cvs] r11742 - in tags/0.14.1: . abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 5 17:12:01 2009 New Revision: 11742 Log: Tag 0.14.1. Added: tags/0.14.1/ - copied from r11741, /branches/0.14.x/ Modified: tags/0.14.1/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.14.1/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.14.1/abcl/src/org/armedbear/lisp/Version.java Sun Apr 5 17:12:01 2009 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.14.1-dev"; + return "0.14.1"; } } From ehuelsmann at common-lisp.net Sun Apr 5 21:12:57 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 05 Apr 2009 17:12:57 -0400 Subject: [armedbear-cvs] r11743 - branches/0.14.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 5 17:12:56 2009 New Revision: 11743 Log: Bump version number. Modified: branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.14.x/abcl/src/org/armedbear/lisp/Version.java Sun Apr 5 17:12:56 2009 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.14.1-dev"; + return "0.14.2-dev"; } } From ehuelsmann at common-lisp.net Mon Apr 6 19:24:23 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 06 Apr 2009 15:24:23 -0400 Subject: [armedbear-cvs] r11744 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Apr 6 15:24:20 2009 New Revision: 11744 Log: Remove references to "libabcl.so" which was deleted sometime during 0.13. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Mon Apr 6 15:24:20 2009 @@ -39,7 +39,6 @@ import java.io.InputStream; import java.io.InputStreamReader; import java.io.OutputStream; -import java.lang.reflect.Method; public final class Interpreter extends Lisp { @@ -82,17 +81,6 @@ out._writeString(banner()); out._finishOutput(); } - if (Utilities.isPlatformUnix) { - try { - System.loadLibrary("abcl"); - Class c = Class.forName("org.armedbear.lisp.Native"); - Method m = c.getMethod("initialize", (Class[]) null); - m.invoke((Object) null, (Object[]) null); - if (!noinform) - getStandardOutput()._writeString("Control-C handler installed.\n"); - } - catch (Throwable t) {} - } if (noinform) _NOINFORM_.setSymbolValue(T); else { From ehuelsmann at common-lisp.net Mon Apr 6 19:40:38 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 06 Apr 2009 15:40:38 -0400 Subject: [armedbear-cvs] r11745 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Apr 6 15:40:37 2009 New Revision: 11745 Log: Remove since-long deprecated initialization files and unsupported locations (:\.abclrc is write protected by Vista). Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Mon Apr 6 15:40:37 2009 @@ -49,8 +49,8 @@ private final InputStream inputStream; private final OutputStream outputStream; - private static boolean noinit; - private static boolean noinform; + private static boolean noinit = false; + private static boolean noinform = false; public static synchronized Interpreter getInstance() { @@ -223,29 +223,6 @@ Load.load(file.getCanonicalPath()); return; } - if (Utilities.isPlatformWindows) { - file = new File("C:\\.abclrc"); - if (file.isFile()) { - Load.load(file.getCanonicalPath()); - return; - } - } - file = new File(userHome, ".ablrc"); - if (file.isFile()) { - String message = - "Warning: use of .ablrc is deprecated; use .abclrc instead."; - getStandardOutput()._writeLine(message); - Load.load(file.getCanonicalPath()); - return; - } - file = new File(userHome, ".ablisprc"); - if (file.isFile()) { - String message = - "Warning: use of .ablisprc is deprecated; use .abclrc instead."; - getStandardOutput()._writeLine(message); - Load.load(file.getCanonicalPath()); - return; - } } catch (Throwable t) { t.printStackTrace(); From ehuelsmann at common-lisp.net Mon Apr 6 20:43:52 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 06 Apr 2009 16:43:52 -0400 Subject: [armedbear-cvs] r11746 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Apr 6 16:43:51 2009 New Revision: 11746 Log: Fix reader memory leak. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Mon Apr 6 16:43:51 2009 @@ -518,8 +518,14 @@ } else { - thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); - return faslReadPreservingWhitespace(eofError, eofValue, true, thread); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + try { + thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); + return faslReadPreservingWhitespace(eofError, eofValue, true, thread); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } } } From ehuelsmann at common-lisp.net Tue Apr 7 21:14:31 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 07 Apr 2009 17:14:31 -0400 Subject: [armedbear-cvs] r11747 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Apr 7 17:14:28 2009 New Revision: 11747 Log: Fix excessive stack use while resolving #n= and #n#: Don't recurse into the CDR of lists being read; instead, loop over the successive CDRs in the list. 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 Tue Apr 7 17:14:28 2009 @@ -154,14 +154,18 @@ ;; 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) - (cond ((not (typep tree - '(or cons (array t) structure-object standard-object))) - (let ((entry (find tree old-new-alist :key #'second))) - (if entry (third entry) 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*)) - (setf (gethash tree *sharp-equal-circle-table*) t) (cond ((typep tree 'structure-object) + (setf (gethash tree *sharp-equal-circle-table*) t) (do ((i 0 (1+ i)) (end (structure-length tree))) ((= i end)) @@ -170,6 +174,7 @@ (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)) @@ -178,6 +183,7 @@ ;; (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)) @@ -185,15 +191,35 @@ (new (circle-subst old-new-alist old))) (unless (eq old new) (setf (row-major-aref tree i) new))))) - (t - (let ((a (circle-subst old-new-alist (car tree))) - (d (circle-subst old-new-alist (cdr tree)))) - (unless (eq a (car tree)) - (rplaca tree a)) - (unless (eq d (cdr tree)) - (rplacd tree d))))) + (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) ;; CONSes handled in the loop + (setf (gethash d *sharp-equal-circle-table*) t) + d) + ((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))) + (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 From ehuelsmann at common-lisp.net Wed Apr 8 06:04:31 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 08 Apr 2009 02:04:31 -0400 Subject: [armedbear-cvs] r11748 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 8 02:04:29 2009 New Revision: 11748 Log: Revert r11746. It turns out to break the ANSI test suite and I don't know why. To be reinstated when I gain that insight. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Wed Apr 8 02:04:29 2009 @@ -518,14 +518,8 @@ } else { - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - try { - thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); - return faslReadPreservingWhitespace(eofError, eofValue, true, thread); - } - finally { - thread.lastSpecialBinding = lastSpecialBinding; - } + thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); + return faslReadPreservingWhitespace(eofError, eofValue, true, thread); } } From ehuelsmann at common-lisp.net Thu Apr 9 14:17:36 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 09 Apr 2009 10:17:36 -0400 Subject: [armedbear-cvs] r11749 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Apr 9 10:17:33 2009 New Revision: 11749 Log: Follow up to r11747: remove SETF which causes iteration to terminate, while without it, it will merely be handled in the next iteration. 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 Thu Apr 9 10:17:33 2009 @@ -205,9 +205,7 @@ (circle-subst old-new-alist c) (element-replacement c))) (b (cond - ((consp d) ;; CONSes handled in the loop - (setf (gethash d *sharp-equal-circle-table*) t) - d) + ((consp d) d) ;; CONSes handled in the loop ((recursable-element-p d) ;; ARRAY, STRUCTURE-OBJECT and STANDARD-OBJECT ;; handled in recursive calls From mevenson at common-lisp.net Sat Apr 11 21:47:08 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 11 Apr 2009 17:47:08 -0400 Subject: [armedbear-cvs] r11750 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Apr 11 17:47:05 2009 New Revision: 11750 Log: Don't die if if the Java system property 'os.arch' doesn't exist. Google App Engine's JVM does not provide the "os.arch" system, but we shouldn't be failing for this anyways 'cuz argubly the machine type is Java. Still, this might be useful for determining JNI libraries to load. If 'os.arch' doesn't exist, use 'UNKNOWN' for machine-type. Thanks to Vladimir V. Korablin for the patch. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/machine_type.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 Sat Apr 11 17:47:05 2009 @@ -2214,12 +2214,14 @@ static { String os_arch = System.getProperty("os.arch"); - if (os_arch.equals("amd64")) - Symbol.FEATURES.setSymbolValue(new Cons(Keyword.X86_64, - Symbol.FEATURES.getSymbolValue())); - else if (os_arch.equals("x86")) - Symbol.FEATURES.setSymbolValue(new Cons(Keyword.X86, - Symbol.FEATURES.getSymbolValue())); + if(os_arch != null) { + if (os_arch.equals("amd64")) + Symbol.FEATURES.setSymbolValue(new Cons(Keyword.X86_64, + Symbol.FEATURES.getSymbolValue())); + else if (os_arch.equals("x86")) + Symbol.FEATURES.setSymbolValue(new Cons(Keyword.X86, + Symbol.FEATURES.getSymbolValue())); + } } static Modified: trunk/abcl/src/org/armedbear/lisp/machine_type.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/machine_type.java (original) +++ trunk/abcl/src/org/armedbear/lisp/machine_type.java Sat Apr 11 17:47:05 2009 @@ -45,7 +45,9 @@ public LispObject execute() throws ConditionThrowable { String s = System.getProperty("os.arch"); - if (s.equals("amd64")) + if (s == null) + s = "UNKNOWN"; + else if (s.equals("amd64")) s = "X86-64"; else s = s.toUpperCase(); From ehuelsmann at common-lisp.net Sun Apr 12 03:21:15 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 11 Apr 2009 23:21:15 -0400 Subject: [armedbear-cvs] r11751 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Apr 11 23:21:13 2009 New Revision: 11751 Log: Don't catch STDERR output into the property, so that it becomes usable for printing debug information. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sat Apr 11 23:21:13 2009 @@ -228,7 +228,8 @@ + classname="org.armedbear.lisp.Main" + logerror="yes"> From ehuelsmann at common-lisp.net Sun Apr 12 03:23:04 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 11 Apr 2009 23:23:04 -0400 Subject: [armedbear-cvs] r11752 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Apr 11 23:23:03 2009 New Revision: 11752 Log: Use the -jar option for a shorter command line: the .jar contains the right MANIFEST.MF to do so. Modified: trunk/abcl/abcl.bat.in trunk/abcl/abcl.in Modified: trunk/abcl/abcl.bat.in ============================================================================== --- trunk/abcl/abcl.bat.in (original) +++ trunk/abcl/abcl.bat.in Sat Apr 11 23:23:03 2009 @@ -1 +1 @@ -"@JAVA@" @ABCL_JAVA_OPTIONS@ -cp "@ABCL_CLASSPATH@" org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9 +@"@JAVA@" @ABCL_JAVA_OPTIONS@ -jar "@ABCL_CLASSPATH@" %1 %2 %3 %4 %5 %6 %7 %8 %9 Modified: trunk/abcl/abcl.in ============================================================================== --- trunk/abcl/abcl.in (original) +++ trunk/abcl/abcl.in Sat Apr 11 23:23:03 2009 @@ -3,6 +3,7 @@ # abcl.in # Copyright (C) 2004 Peter Graves +# Copyright (C) 2009 Erik Huelsmann # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License @@ -18,4 +19,4 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -exec @JAVA@ @ABCL_JAVA_OPTIONS@ -Xrs -Djava.library.path=@ABCL_LIBPATH@ -cp @ABCL_CLASSPATH@ org.armedbear.lisp.Main "$@" +exec @JAVA@ @ABCL_JAVA_OPTIONS@ -jar @ABCL_CLASSPATH@ "$@" From ehuelsmann at common-lisp.net Sun Apr 12 10:41:30 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 12 Apr 2009 06:41:30 -0400 Subject: [armedbear-cvs] r11753 - trunk/j Message-ID: Author: ehuelsmann Date: Sun Apr 12 06:41:27 2009 New Revision: 11753 Log: Remove J from our repository. It's being maintained at SourceForge and our copy is now out-dated. Removed: trunk/j/ From ehuelsmann at common-lisp.net Sun Apr 12 13:47:05 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 12 Apr 2009 09:47:05 -0400 Subject: [armedbear-cvs] r11755 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 12 09:47:04 2009 New Revision: 11755 Log: Implement MACROEXPAND-ALL and COMPILER-LET as internal symbols to the SYSTEM package for people to experiment with. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Sun Apr 12 09:47:04 2009 @@ -1018,6 +1018,19 @@ (in-package #:system) +(defun macroexpand-all (form &optional env) + (let ((*compile-file-environment* env)) + (precompile-form form nil))) + +(defmacro compiler-let (bindings &body forms &environment env) + (let ((bindings (mapcar #'(lambda (binding) + (if (atom binding) (list binding) binding)) + bindings))) + (progv (mapcar #'car bindings) + (mapcar #'(lambda (binding) + (eval (cadr binding))) bindings) + (macroexpand-all `(progn , at forms) env)))) + (defun precompile (name &optional definition) (unless definition (setq definition (or (and (symbolp name) (macro-function name)) From ehuelsmann at common-lisp.net Tue Apr 14 09:24:22 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 14 Apr 2009 05:24:22 -0400 Subject: [armedbear-cvs] r11756 - public_html Message-ID: Author: ehuelsmann Date: Tue Apr 14 05:24:17 2009 New Revision: 11756 Log: Update website to agree with latest release status. Added: public_html/release-notes-0.14.shtml Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Tue Apr 14 05:24:17 2009 @@ -22,8 +22,8 @@ Overview -Latest release: 0.0.13 -Release notes +Latest release: 0.14.1 +Release notes What people say about ABCL @@ -55,7 +55,7 @@

ABCL is free software and comes with ABSOLUTELY NO WARRANTY.

- The latest version is 0.13.0, released February 28, 2009. + The latest version is 0.14.1, released April 5, 2009. @@ -76,11 +76,11 @@
- abcl-0.13.0.tar.gz - (source, 656652 bytes) + abcl-src-0.14.1.tar.gz + (source, 632584 bytes)

- abcl-0.13.0.zip - (source, 1130754 bytes) + abcl-src-0.14.1.zip + (source, 1098276 bytes)

@@ -108,14 +108,13 @@ quality of ABCL being good enough for their needs though. See the testimonials page.

- ABCL 0.13.0 fails 44 out of 21702 tests in the ANSI test suite - in interpreted mode. In compiled mode ABCL 0.13.0 also fails 44 tests, - coming from ca 48 in the last release. + ABCL 0.14.1 fails 43 out of 21702 tests in the ANSI test suite + in interpreted mode. In compiled mode ABCL 0.14.1 also fails 43 tests, + coming from ca 44 in the last release. Most notable recent fixes relate to issues found through running the Maxima test suite. 0.13.0 is now able to run the test suite - without crashing. Before, some testcases could not be completed, - causing Java side errors. This is the issue resolved. The Maxima - tests don't run without errors, still. + without only ca 75 failing tests, coming from ca 1400 failures + october 2008 (6 months ago).

ABCL's CLOS is slow and does not handle on-the-fly redefinition of classes correctly. There is no support for the long @@ -123,8 +122,10 @@ features are also missing. Enough CLOS is there to run ASDF and CL-PPCRE, if you're in no hurry. There's no MOP worth mentioning.

- Since this is an early release, there might be build problems as - well as runtime bugs. + Due to the age of the source code (when compared to several other + implementations) you're more likely to find bugs in ABCL. However, + we're committed to fixing any bugs you find. Patches (bugfixes as + well as features) are most welcome.

Please report problems to the j development mailing list (you must be subscribed to post).

Added: public_html/release-notes-0.14.shtml ============================================================================== --- (empty file) +++ public_html/release-notes-0.14.shtml Tue Apr 14 05:24:17 2009 @@ -0,0 +1,85 @@ + + + + + <!--#include virtual="project-name" --> + + + + + + +

+

+
+ + +

Release notes for ABCL 0.14

+

+ Major changes and new features +

+
+
Fixed special bindings un-binding in compiled code for + MULTIPLE-VALUE-BIND, LET, LET*, PROGV and function bodies
+ +
Special bindings now will get unbound even in case of (non-Lisp) + exceptions. +
+
Reduced ANSI failures in interpreted mode
+
RESTART-CASE wrongly didn't use the macro expansion environment + to expand subforms. +
+
Lisp build system changed for parity with the Ant based build
+
The Lisp build was lagging behind on adjustments made to the Ant + based build. abcl.jar generated from either should now be the same. +
+
Several fixes to numeric calculations
+
EXPT fixed for (EXPT NUMBER BIGNUM) and (EXPT BIGNUM RATIO). + Also, ACOS with a complex double-float argument. +
+
+ + +

Release notes for ABCL 0.13

+ +

+ Major changes and new features +

+
+
JSR-223: Java Scripting Plugin +
+
ABCL supports - when built with the javax.script package + in the CLASSPATH - the interfaces defined in JSR-223. +
+
Support for inlining FLOAT results
+
When given the right DECLARE forms, ABCL is now able to inline + calculations and intermediate values relating to FLOAT types. Before, + it used to box all FLOAT values and results, without inlining.
+
Compiler cleanups
+
Lots of code cleanup in the compiler, such as elimination of + nearly-equivalent code blocks.
+
TRACE-ing fixes
+
TRACE should no longer blow up when tracing FORMAT or inside + the compiler.
+
Support for "partial" wildcards in CL:DIRECTORY
+
Patterns such as #p"cl-*.lisp" are now supported.
+
+ +

Release notes for ABCL 0.12 and older

+ +

These release notes have not been created before. If someone takes + the effort to create them, they will be added for 0.11 and 0.12.

+ +
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id: index.shtml 11358 2008-10-18 22:10:11Z ehuelsmann $
+ + From ehuelsmann at common-lisp.net Tue Apr 14 09:48:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 14 Apr 2009 05:48:02 -0400 Subject: [armedbear-cvs] r11757 - public_html Message-ID: Author: ehuelsmann Date: Tue Apr 14 05:48:00 2009 New Revision: 11757 Log: Add a left menu bar and limit the width of the body text. Added: public_html/left-menu Modified: public_html/index.shtml public_html/release-notes-0.13.shtml public_html/release-notes-0.14.shtml public_html/testimonials.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Tue Apr 14 05:48:00 2009 @@ -33,6 +33,11 @@
+ + + +
+

About ABCL

@@ -158,6 +163,9 @@ as Java 1.5. +
+ +

Back to Common-lisp.net.

@@ -165,5 +173,6 @@ Valid XHTML 1.0 Strict
$Id$
+ Added: public_html/left-menu ============================================================================== --- (empty file) +++ public_html/left-menu Tue Apr 14 05:48:00 2009 @@ -0,0 +1,5 @@ + Modified: public_html/release-notes-0.13.shtml ============================================================================== --- public_html/release-notes-0.13.shtml (original) +++ public_html/release-notes-0.13.shtml Tue Apr 14 05:48:00 2009 @@ -17,6 +17,11 @@

+ + +
+ +

Release notes for ABCL 0.13

@@ -47,6 +52,9 @@

These release notes have not been created before. If someone takes the effort to create them, they will be added for 0.11 and 0.12.

+
+ +

Back to Common-lisp.net.

@@ -54,5 +62,6 @@ Valid XHTML 1.0 Strict
$Id: index.shtml 11358 2008-10-18 22:10:11Z ehuelsmann $
+ Modified: public_html/release-notes-0.14.shtml ============================================================================== --- public_html/release-notes-0.14.shtml (original) +++ public_html/release-notes-0.14.shtml Tue Apr 14 05:48:00 2009 @@ -7,7 +7,7 @@ @@ -17,10 +17,13 @@

+ + +

Release notes for ABCL 0.14

- Major changes and new features + Major changes and new features

Fixed special bindings un-binding in compiled code for @@ -47,7 +50,8 @@

Release notes for ABCL 0.13

- Major changes and new features + Major changes and new features +

JSR-223: Java Scripting Plugin @@ -74,6 +78,9 @@

These release notes have not been created before. If someone takes the effort to create them, they will be added for 0.11 and 0.12.

+
+ +

Back to Common-lisp.net.

@@ -81,5 +88,6 @@ Valid XHTML 1.0 Strict
$Id: index.shtml 11358 2008-10-18 22:10:11Z ehuelsmann $
+ Modified: public_html/testimonials.shtml ============================================================================== --- public_html/testimonials.shtml (original) +++ public_html/testimonials.shtml Tue Apr 14 05:48:00 2009 @@ -22,11 +22,9 @@

-
+ + +

Testimonials

From ehuelsmann at common-lisp.net Tue Apr 14 09:53:37 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 14 Apr 2009 05:53:37 -0400 Subject: [armedbear-cvs] r11758 - public_html Message-ID: Author: ehuelsmann Date: Tue Apr 14 05:53:35 2009 New Revision: 11758 Log: Add a (courtesy) reference to J. Modified: public_html/left-menu Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Tue Apr 14 05:53:35 2009 @@ -2,4 +2,8 @@ Project page
Testimonials +
+
+J - the editor +
From ehuelsmann at common-lisp.net Tue Apr 14 09:58:42 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 14 Apr 2009 05:58:42 -0400 Subject: [armedbear-cvs] r11759 - public_html Message-ID: Author: ehuelsmann Date: Tue Apr 14 05:58:40 2009 New Revision: 11759 Log: Fix the J reference. Modified: public_html/left-menu Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Tue Apr 14 05:58:40 2009 @@ -4,6 +4,6 @@

-J - the editor +J - the editor
From ehuelsmann at common-lisp.net Tue Apr 14 20:32:26 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 14 Apr 2009 16:32:26 -0400 Subject: [armedbear-cvs] r11760 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Apr 14 16:32:24 2009 New Revision: 11760 Log: Remove check for properness of arguments list. The check breaks AP5 and its removal doesn't appear to break any ANSI tests. 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 Apr 14 16:32:24 2009 @@ -211,7 +211,6 @@ { if (form instanceof Cons) { - form.length(); // Force an error if form is not a proper list. LispObject car = ((Cons)form).car; if (car instanceof Symbol) { From ehuelsmann at common-lisp.net Wed Apr 15 07:05:43 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 15 Apr 2009 03:05:43 -0400 Subject: [armedbear-cvs] r11761 - trunk/abcl/web Message-ID: Author: ehuelsmann Date: Wed Apr 15 03:05:41 2009 New Revision: 11761 Log: Delete web/ folder; we have a toplevel public_html/ which we use now. Removed: trunk/abcl/web/ From ehuelsmann at common-lisp.net Fri Apr 17 20:00:22 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 17 Apr 2009 16:00:22 -0400 Subject: [armedbear-cvs] r11762 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Apr 17 16:00:18 2009 New Revision: 11762 Log: Fix JCLASS null return value; signal a lisp error instead. Found by: Russell McManus (russel_mcmanus at yahoo com) Modified: trunk/abcl/src/org/armedbear/lisp/Java.java Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Fri Apr 17 16:00:18 2009 @@ -851,7 +851,11 @@ if (s.equals("double")) return Double.TYPE; // Not a primitive Java type. - return classForName(s); + Class c = classForName(s); + if (c == null) + error(new LispError(s + " does not designate a Java class.")); + + return c; } // It's not a string, so it must be a JavaObject. final JavaObject javaObject; From ehuelsmann at common-lisp.net Sat Apr 18 19:08:10 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 18 Apr 2009 15:08:10 -0400 Subject: [armedbear-cvs] r11763 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Apr 18 15:08:08 2009 New Revision: 11763 Log: Fix COMPILE and COMPILE-FILE secondary and tertiary return values in case of successful completion with multiple invocations inside a single WITH-COMPILATION-UNIT and failed previous invocations. Found by: Robert Dodier (robert_dodier at yahoo dot com) 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 Sat Apr 18 15:08:08 2009 @@ -403,8 +403,8 @@ (type (pathname-type output-file)) (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp")) output-file)) - (warnings-p t) - (failure-p t)) + (warnings-p nil) + (failure-p nil)) (with-open-file (in input-file :direction :input) (let* ((*compile-file-pathname* (pathname in)) (*compile-file-truename* (truename in)) @@ -436,20 +436,26 @@ (%stream-terpri out) (write (list 'setq '*source* *compile-file-truename*) :stream out) (%stream-terpri out)) - (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))) + (handler-bind ((style-warning #'(lambda (c) + (declare (ignore c)) + (setf warnings-p t) + nil)) + ((or warning + compiler-error) #'(lambda (c) + (declare (ignore c)) + (setf warnings-p t + failure-p t) + nil))) + (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))))) - (cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*)) - (setf warnings-p nil failure-p nil)) - ((zerop (+ jvm::*errors* jvm::*warnings*)) - (setf failure-p nil)))) + (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 Sat Apr 18 15:08:08 2009 @@ -8760,14 +8760,27 @@ (symbol-package name) *package*)) compiled-function - (warnings-p t) - (failure-p t)) + (warnings-p nil) + (failure-p nil)) (with-compilation-unit () (with-saved-compiler-policy (let* ((tempfile (make-temp-file))) (unwind-protect (setf compiled-function - (load-compiled-function (compile-defun name expr env tempfile))) + (load-compiled-function + (handler-bind ((style-warning + #'(lambda (c) + (declare (ignore c)) + (setf warnings-p t) + nil)) + ((or warning + compiler-error) + #'(lambda (c) + (declare (ignore c)) + (setf warnings-p t + failure-p t) + nil))) + (compile-defun name expr env tempfile)))) (delete-file tempfile)))) (when (and name (functionp compiled-function)) (sys::%set-lambda-name compiled-function name) @@ -8780,11 +8793,7 @@ (setf (fdefinition name) (if (macro-function name) (make-macro name compiled-function) - compiled-function)))))) - (cond ((zerop (+ *errors* *warnings* *style-warnings*)) - (setf warnings-p nil failure-p nil)) - ((zerop (+ *errors* *warnings*)) - (setf failure-p nil)))) + compiled-function))))))) (values (or name compiled-function) warnings-p failure-p)))) (defun jvm-compile (name &optional definition) From ehuelsmann at common-lisp.net Sat Apr 18 20:17:41 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 18 Apr 2009 16:17:41 -0400 Subject: [armedbear-cvs] r11764 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Apr 18 16:17:41 2009 New Revision: 11764 Log: Don't use the implementation details in WITH-COMPILATION-UNIT to signal errors. Move around some code to achieve that. At the same time, switch away from using specials in favor of variables being closed over. Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp 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 Sat Apr 18 16:17:41 2009 @@ -270,9 +270,18 @@ (check-lisp-home) (time (with-compilation-unit () - (let ((*compile-file-zip* zip)) - (%compile-system :output-path output-path)) - (when (zerop (+ jvm::*errors* jvm::*warnings*)) - (setf status 0)))) + (let ((*compile-file-zip* zip) + failure-p) + (handler-bind (((or warning + compiler-error) + #'(lambda (c) + (declare (ignore c)) + (setf failure-p t) + ;; only register that we had this type of signal + ;; defer the actual handling to another handler + nil))) + (%compile-system :output-path output-path)) + (unless failure-p + (setf status 0))))) (when quit (quit :status status)))) 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 Apr 18 16:17:41 2009 @@ -1002,56 +1002,6 @@ (fix-boxing representation nil) (emit-move-from-stack target representation)) -(defvar *style-warnings* nil) -(defvar *warnings* nil) -(defvar *errors* nil) - -(defvar *last-error-context* nil) - -(defun note-error-context () - (let ((context *compiler-error-context*)) - (when (and context (neq context *last-error-context*)) - (fresh-line *error-output*) - (princ "; in " *error-output*) - (let ((*print-length* 2) - (*print-level* 2) - (*print-pretty* nil)) - (prin1 context *error-output*)) - (terpri *error-output*) - (terpri *error-output*) - (setf *last-error-context* context)))) - -(defvar *resignal-compiler-warnings* nil) ; bind this to t inside slime compilation - -(defun handle-style-warning (condition) - (cond (*resignal-compiler-warnings* - (signal condition)) - (t - (unless *suppress-compiler-warnings* - (fresh-line *error-output*) - (note-error-context) - (format *error-output* "; Caught ~A:~%; ~A~2%" (type-of condition) condition)) - (incf *style-warnings*) - (muffle-warning)))) - -(defun handle-warning (condition) - (cond (*resignal-compiler-warnings* - (signal condition)) - (t - (unless *suppress-compiler-warnings* - (fresh-line *error-output*) - (note-error-context) - (format *error-output* "; Caught ~A:~%; ~A~2%" (type-of condition) condition)) - (incf *warnings*) - (muffle-warning)))) - -(defun handle-compiler-error (condition) - (fresh-line *error-output*) - (note-error-context) - (format *error-output* "; Caught ERROR:~%; ~A~2%" condition) - (incf *errors*) - (throw 'compile-defun-abort (funcall *compiler-error-bailout*))) - ;; "In addition to situations for which the standard specifies that conditions ;; of type WARNING must or might be signaled, warnings might be signaled in ;; situations where the compiler can determine that the consequences are @@ -8697,44 +8647,91 @@ (defvar *catch-errors* t) +(defvar *last-error-context* nil) + +(defun note-error-context () + (let ((context *compiler-error-context*)) + (when (and context (neq context *last-error-context*)) + (fresh-line *error-output*) + (princ "; in " *error-output*) + (let ((*print-length* 2) + (*print-level* 2) + (*print-pretty* nil)) + (prin1 context *error-output*)) + (terpri *error-output*) + (terpri *error-output*) + (setf *last-error-context* context)))) + + +(defvar *resignal-compiler-warnings* nil + "Bind this to t inside slime compilation") + +(defun handle-warning (condition) + (cond (*resignal-compiler-warnings* + (signal condition)) + (t + (unless *suppress-compiler-warnings* + (fresh-line *error-output*) + (note-error-context) + (format *error-output* "; Caught ~A:~%; ~A~2%" + (type-of condition) condition)) + (muffle-warning)))) + +(defun handle-compiler-error (condition) + (fresh-line *error-output*) + (note-error-context) + (format *error-output* "; Caught ERROR:~%; ~A~2%" condition) + (throw 'compile-defun-abort (funcall *compiler-error-bailout*))) + (defvar *in-compilation-unit* nil) (defmacro with-compilation-unit (options &body body) `(%with-compilation-unit (lambda () , at body) , at options)) (defun %with-compilation-unit (fn &key override) - (handler-bind ((style-warning 'handle-style-warning) - (warning 'handle-warning) - (compiler-error 'handle-compiler-error)) - (if (and *in-compilation-unit* (not override)) - (funcall fn) - (let ((*style-warnings* 0) - (*warnings* 0) - (*errors* 0) - (*defined-functions* nil) - (*undefined-functions* nil) - (*in-compilation-unit* t)) - (unwind-protect - (funcall fn) - (unless (or (and *suppress-compiler-warnings* (zerop *errors*)) - (and (zerop (+ *errors* *warnings* *style-warnings*)) - (null *undefined-functions*))) - (format *error-output* "~%; Compilation unit finished~%") - (unless (zerop *errors*) - (format *error-output* "; Caught ~D ERROR condition~P~%" - *errors* *errors*)) - (unless *suppress-compiler-warnings* - (unless (zerop *warnings*) - (format *error-output* "; Caught ~D WARNING condition~P~%" - *warnings* *warnings*)) - (unless (zerop *style-warnings*) - (format *error-output* "; Caught ~D STYLE-WARNING condition~P~%" - *style-warnings* *style-warnings*)) - (when *undefined-functions* - (format *error-output* "; The following functions were used but not defined:~%") - (dolist (name *undefined-functions*) - (format *error-output* "; ~S~%" name)))) - (terpri *error-output*))))))) + (if (and *in-compilation-unit* (not override)) + (funcall fn) + (let ((style-warnings 0) + (warnings 0) + (errors 0) + (*defined-functions* nil) + (*undefined-functions* nil) + (*in-compilation-unit* t)) + (unwind-protect + (handler-bind ((style-warning #'(lambda (c) + (incf style-warnings) + (handle-warning c))) + (warning #'(lambda (c) + (incf warnings) + (handle-warning c))) + (compiler-error #'(lambda (c) + (incf errors) + (handle-compiler-error c)))) + (funcall fn)) + (unless (or (and *suppress-compiler-warnings* (zerop errors)) + (and (zerop (+ errors warnings style-warnings)) + (null *undefined-functions*))) + (format *error-output* + "~%; Compilation unit finished~%") + (unless (zerop errors) + (format *error-output* + "; Caught ~D ERROR condition~P~%" + errors errors)) + (unless *suppress-compiler-warnings* + (unless (zerop warnings) + (format *error-output* + "; Caught ~D WARNING condition~P~%" + warnings warnings)) + (unless (zerop style-warnings) + (format *error-output* + "; Caught ~D STYLE-WARNING condition~P~%" + style-warnings style-warnings)) + (when *undefined-functions* + (format *error-output* + "; The following functions were used but not defined:~%") + (dolist (name *undefined-functions*) + (format *error-output* "; ~S~%" name)))) + (terpri *error-output*)))))) (defun get-lambda-to-compile (thing) (if (and (consp thing) From ehuelsmann at common-lisp.net Sun Apr 19 08:30:00 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 19 Apr 2009 04:30:00 -0400 Subject: [armedbear-cvs] r11765 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 19 04:29:57 2009 New Revision: 11765 Log: Use pathname "calculations" to determine the output file name for the ZIP archive which is to become the .ABCL file. 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 Sun Apr 19 04:29:57 2009 @@ -459,8 +459,13 @@ (rename-file temp-file output-file) (when *compile-file-zip* - (let ((zipfile (concatenate 'string (namestring output-file) ".zip")) - (pathnames ())) + (let* ((type ;; Don't use ".zip", it'll result in an extension + ;; with a dot, which is rejected by NAMESTRING + (%format nil "~A~A" (pathname-type output-file) "-zip")) + (zipfile (namestring + (merge-pathnames (make-pathname :type type) + output-file))) + (pathnames ())) (dotimes (i *class-number*) (let* ((file-namestring (%format nil "~A-~D.cls" (substitute #\_ #\. (pathname-name output-file)) From ehuelsmann at common-lisp.net Sun Apr 19 08:33:33 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 19 Apr 2009 04:33:33 -0400 Subject: [armedbear-cvs] r11766 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 19 04:33:29 2009 New Revision: 11766 Log: In MERGE-PATHNAMES, if the pathname to be returned is of type PATHNAME, resolve PATHNAME-DEFAULTS to a PATHNAME, if it's a LOGICAL-PATHNAME. Fixes COMPILE-FILE.17 and COMPILE-FILE.18 ANSI tests. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sun Apr 19 04:33:29 2009 @@ -1152,8 +1152,11 @@ Pathname p; if (pathname instanceof LogicalPathname) p = new LogicalPathname(); - else + else { p = new Pathname(); + if (defaultPathname instanceof LogicalPathname) + defaultPathname = LogicalPathname.translateLogicalPathname((LogicalPathname)defaultPathname); + } if (pathname.host != NIL) p.host = pathname.host; else From ehuelsmann at common-lisp.net Sun Apr 19 20:10:58 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 19 Apr 2009 16:10:58 -0400 Subject: [armedbear-cvs] r11767 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 19 16:10:56 2009 New Revision: 11767 Log: * Stop declaring symbols SPECIAL mid-environment: usually, this pollutes the environment, as you'd want to create a new one to store the special binding in. * Fix the single ANSI test failure this causes (SYMBOL-MACROLET.8) by always creating a new environment and processing the declarations in SYMBOL-MACROLET. Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.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 Sun Apr 19 16:10:56 2009 @@ -209,50 +209,43 @@ { LispObject varList = checkList(args.car()); final LispThread thread = LispThread.currentThread(); - if (varList != NIL) - { - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - try - { - Environment ext = new Environment(env); - // Declare our free specials, this will correctly raise - LispObject body = ext.processDeclarations(args.cdr()); - - for (int i = varList.length(); i-- > 0;) - { - LispObject obj = varList.car(); - varList = varList.cdr(); - if (obj instanceof Cons && obj.length() == 2) - { - Symbol symbol = checkSymbol(obj.car()); - if (symbol.isSpecialVariable() - || ext.isDeclaredSpecial(symbol)) - { - return error(new ProgramError( + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(env); + try + { + // Declare our free specials, this will correctly raise + LispObject body = ext.processDeclarations(args.cdr()); + + for (int i = varList.length(); i-- > 0;) + { + LispObject obj = varList.car(); + varList = varList.cdr(); + if (obj instanceof Cons && obj.length() == 2) + { + Symbol symbol = checkSymbol(obj.car()); + if (symbol.isSpecialVariable() + || ext.isDeclaredSpecial(symbol)) + { + return error(new ProgramError( "Attempt to bind the special variable " + symbol.writeToString() + " with SYMBOL-MACROLET.")); - } - bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread); - } - else - { - return error(new ProgramError( - "Malformed symbol-expansion pair in SYMBOL-MACROLET: " + - obj.writeToString())); - } - } - return progn(body, ext, thread); + } + bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread); + } + else + { + return error(new ProgramError( + "Malformed symbol-expansion pair in SYMBOL-MACROLET: " + + obj.writeToString())); + } + } + return progn(body, ext, thread); } - finally - { + finally + { thread.lastSpecialBinding = lastSpecialBinding; - } - } - else - { - return progn(args.cdr(), env, thread); - } + } } }; @@ -447,21 +440,6 @@ public LispObject execute(LispObject args, Environment env) throws ConditionThrowable { - while (args != NIL) - { - LispObject decl = args.car(); - args = args.cdr(); - if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) - { - LispObject vars = decl.cdr(); - while (vars != NIL) - { - Symbol var = checkSymbol(vars.car()); - env.declareSpecial(var); - vars = vars.cdr(); - } - } - } return NIL; } }; From ehuelsmann at common-lisp.net Mon Apr 20 08:13:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 20 Apr 2009 04:13:02 -0400 Subject: [armedbear-cvs] r11768 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Apr 20 04:13:00 2009 New Revision: 11768 Log: Use 'innerEnv' to evaluate the body in, since that's where we declared our free specials. Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.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 Mon Apr 20 04:13:00 2009 @@ -382,7 +382,7 @@ final Environment innerEnv = new Environment(ext); LispObject body = args.cdr(); body = innerEnv.processDeclarations(body); - return progn(body, ext, thread); + return progn(body, innerEnv, thread); } finally { From ehuelsmann at common-lisp.net Mon Apr 20 08:31:35 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 20 Apr 2009 04:31:35 -0400 Subject: [armedbear-cvs] r11769 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Apr 20 04:31:34 2009 New Revision: 11769 Log: Rename variables to be more in line with the env/ext pattern used elsewhere. Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.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 Mon Apr 20 04:31:34 2009 @@ -330,7 +330,7 @@ LispObject defs = checkList(args.car()); final LispThread thread = LispThread.currentThread(); final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - final Environment ext = new Environment(env); + final Environment funEnv = new Environment(env); while (defs != NIL) { final LispObject def = checkList(defs.car()); @@ -373,16 +373,16 @@ list(recursive ? Symbol.LABELS : Symbol.FLET, name); Closure closure = new Closure(lambda_name, lambda_expression, - recursive ? ext : env); - ext.addFunctionBinding(name, closure); + recursive ? funEnv : env); + funEnv.addFunctionBinding(name, closure); defs = defs.cdr(); } try { - final Environment innerEnv = new Environment(ext); + final Environment ext = new Environment(funEnv); LispObject body = args.cdr(); - body = innerEnv.processDeclarations(body); - return progn(body, innerEnv, thread); + body = ext.processDeclarations(body); + return progn(body, ext, thread); } finally { From ehuelsmann at common-lisp.net Mon Apr 20 12:42:39 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 20 Apr 2009 08:42:39 -0400 Subject: [armedbear-cvs] r11770 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Apr 20 08:42:37 2009 New Revision: 11770 Log: Removal of small code duplication. Modified: trunk/abcl/src/org/armedbear/lisp/Environment.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 Mon Apr 20 08:42:37 2009 @@ -57,13 +57,7 @@ // value binding. public Environment(Environment parent, Symbol symbol, LispObject value) { - if (parent != null) - { - vars = parent.vars; - lastFunctionBinding = parent.lastFunctionBinding; - blocks = parent.blocks; - tags = parent.tags; - } + this(parent); vars = new Binding(symbol, value, vars); } From vvoutilainen at common-lisp.net Mon Apr 20 18:32:48 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Mon, 20 Apr 2009 14:32:48 -0400 Subject: [armedbear-cvs] r11771 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Mon Apr 20 14:32:46 2009 New Revision: 11771 Log: Cleanup copy-paste again, this time we get rid of repetition in the execute methods. Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Mon Apr 20 14:32:46 2009 @@ -418,12 +418,13 @@ return execute(new LispObject[0]); } - private final LispObject bindParametersAndExecute( - Environment ext, - LispThread thread, - SpecialBinding lastSpecialBinding) + private final LispObject bindParametersAndExecute(LispObject... objects) throws ConditionThrowable { + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + bindRequiredParameters(ext, thread, objects); if (arity != minArgs) { bindParameterDefaults(optionalParameters, ext, thread); @@ -444,7 +445,7 @@ private final void bindRequiredParameters(Environment ext, LispThread thread, - LispObject... objects) + LispObject[] objects) throws ConditionThrowable { // &whole and &environment before anything @@ -467,12 +468,7 @@ { if (minArgs == 1) { - final LispThread thread = LispThread.currentThread(); - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - Environment ext = new Environment(environment); - bindRequiredParameters(ext, thread, arg); - return bindParametersAndExecute(ext, thread, - lastSpecialBinding); + return bindParametersAndExecute(arg); } else { @@ -486,12 +482,7 @@ { if (minArgs == 2) { - final LispThread thread = LispThread.currentThread(); - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - Environment ext = new Environment(environment); - bindRequiredParameters(ext, thread, first, second); - return bindParametersAndExecute(ext, thread, - lastSpecialBinding); + return bindParametersAndExecute(first, second); } else { @@ -506,12 +497,7 @@ { if (minArgs == 3) { - final LispThread thread = LispThread.currentThread(); - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - Environment ext = new Environment(environment); - bindRequiredParameters(ext, thread, first, second, third); - return bindParametersAndExecute(ext, thread, - lastSpecialBinding); + return bindParametersAndExecute(first, second, third); } else { @@ -526,12 +512,7 @@ { if (minArgs == 4) { - final LispThread thread = LispThread.currentThread(); - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - Environment ext = new Environment(environment); - bindRequiredParameters(ext, thread, first, second, third, fourth); - return bindParametersAndExecute(ext, thread, - lastSpecialBinding); + return bindParametersAndExecute(first, second, third, fourth); } else { @@ -547,13 +528,8 @@ { if (minArgs == 5) { - final LispThread thread = LispThread.currentThread(); - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - Environment ext = new Environment(environment); - bindRequiredParameters(ext, thread, first, second, third, fourth, - fifth); - return bindParametersAndExecute(ext, thread, - lastSpecialBinding); + return bindParametersAndExecute(first, second, third, fourth, + fifth); } else { @@ -569,13 +545,8 @@ { if (minArgs == 6) { - final LispThread thread = LispThread.currentThread(); - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - Environment ext = new Environment(environment); - bindRequiredParameters(ext, thread, first, second, third, fourth, - fifth, sixth); - return bindParametersAndExecute(ext, thread, - lastSpecialBinding); + return bindParametersAndExecute(first, second, third, fourth, + fifth, sixth); } else { @@ -593,13 +564,8 @@ { if (minArgs == 7) { - final LispThread thread = LispThread.currentThread(); - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - Environment ext = new Environment(environment); - bindRequiredParameters(ext, thread, first, second, third, fourth, + return bindParametersAndExecute(first, second, third, fourth, fifth, sixth, seventh); - return bindParametersAndExecute(ext, thread, - lastSpecialBinding); } else { @@ -617,13 +583,8 @@ { if (minArgs == 8) { - final LispThread thread = LispThread.currentThread(); - SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - Environment ext = new Environment(environment); - bindRequiredParameters(ext, thread, first, second, third, fourth, + return bindParametersAndExecute(first, second, third, fourth, fifth, sixth, seventh, eighth); - return bindParametersAndExecute(ext, thread, - lastSpecialBinding); } else { From ehuelsmann at common-lisp.net Mon Apr 20 20:21:38 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 20 Apr 2009 16:21:38 -0400 Subject: [armedbear-cvs] r11772 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Apr 20 16:21:37 2009 New Revision: 11772 Log: Factor out functions to separate declarations, the body and optionally the documentation as well as to determine which variables have been declared special. Modified: trunk/abcl/src/org/armedbear/lisp/Closure.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/SpecialOperators.java trunk/abcl/src/org/armedbear/lisp/dolist.java trunk/abcl/src/org/armedbear/lisp/dotimes.java Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Mon Apr 20 16:21:37 2009 @@ -62,6 +62,7 @@ private Parameter[] keywordParameters = emptyParameterArray; private Parameter[] auxVars = emptyParameterArray; private final LispObject body; + private final LispObject executionBody; private final Environment environment; private final boolean andKey; private final boolean allowOtherKeys; @@ -78,7 +79,7 @@ emptySymbolArray = new Symbol[0]; } private Symbol[] variables = emptySymbolArray; - private Symbol[] specials = emptySymbolArray; + private LispObject specials = NIL; private boolean bindInitForms; @@ -292,6 +293,10 @@ maxArgs = 0; } this.body = lambdaExpression.cddr(); + LispObject bodyAndDecls = parseBody(this.body, false); + this.executionBody = bodyAndDecls.car(); + this.specials = parseSpecials(bodyAndDecls.NTH(1)); + this.environment = env; this.andKey = _andKey; this.allowOtherKeys = _allowOtherKeys; @@ -299,7 +304,6 @@ if (arity >= 0) Debug.assertTrue(arity == minArgs); variables = processVariables(); - specials = processDeclarations(); } private final void processParameters(ArrayList vars, @@ -333,45 +337,6 @@ return array; } - private final Symbol[] processDeclarations() throws ConditionThrowable - { - ArrayList arrayList = null; - LispObject forms = body; - while (forms != NIL) - { - LispObject obj = forms.car(); - if (obj instanceof Cons && obj.car() == Symbol.DECLARE) - { - LispObject decls = obj.cdr(); - while (decls != NIL) - { - LispObject decl = decls.car(); - if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) - { - LispObject vars = decl.cdr(); - while (vars != NIL) - { - Symbol var = checkSymbol(vars.car()); - if (arrayList == null) - arrayList = new ArrayList(); - arrayList.add(var); - vars = vars.cdr(); - } - } - decls = decls.cdr(); - } - forms = forms.cdr(); - } - else - break; - } - if (arrayList == null) - return emptySymbolArray; - Symbol[] array = new Symbol[arrayList.size()]; - arrayList.toArray(array); - return array; - } - private static final void invalidParameter(LispObject obj) throws ConditionThrowable { @@ -411,7 +376,7 @@ { if (arity == 0) { - return progn(body, environment, + return progn(executionBody, environment, LispThread.currentThread()); } else @@ -435,7 +400,7 @@ bindAuxVars(ext, thread); try { - return progn(body, ext, thread); + return progn(executionBody, ext, thread); } finally { @@ -614,8 +579,11 @@ bindArg(specials, sym, args[i], ext, thread); } bindAuxVars(ext, thread); + LispObject s = specials; special: - for (Symbol special : specials) { + while (s != NIL) { + Symbol special = (Symbol)s.car(); + s = s.cdr(); for (Symbol var : variables) if (special == var) continue special; @@ -626,7 +594,7 @@ } try { - return progn(body, ext, thread); + return progn(executionBody, ext, thread); } finally { 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 Mon Apr 20 16:21:37 2009 @@ -96,32 +96,11 @@ final LispObject stack = thread.getStack(); final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; // Process declarations. - LispObject specials = NIL; - while (body != NIL) - { - LispObject obj = body.car(); - if (obj instanceof Cons && obj.car() == Symbol.DECLARE) - { - LispObject decls = obj.cdr(); - while (decls != NIL) - { - LispObject decl = decls.car(); - if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) - { - LispObject names = decl.cdr(); - while (names != NIL) - { - specials = new Cons(names.car(), specials); - names = names.cdr(); - } - } - decls = decls.cdr(); - } - body = body.cdr(); - } - else - break; - } + + final LispObject bodyAndDecls = parseBody(body, false); + LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); + body = bodyAndDecls.car(); + final Environment ext = new Environment(env); for (int i = 0; i < numvars; i++) { 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 Mon Apr 20 16:21:37 2009 @@ -203,33 +203,12 @@ public LispObject processDeclarations(LispObject body) throws ConditionThrowable { - while (body != NIL) - { - LispObject obj = body.car(); - if (obj instanceof Cons && ((Cons)obj).car == Symbol.DECLARE) - { - LispObject decls = ((Cons)obj).cdr; - while (decls != NIL) - { - LispObject decl = decls.car(); - if (decl instanceof Cons && ((Cons)decl).car == Symbol.SPECIAL) - { - LispObject names = ((Cons)decl).cdr; - while (names != NIL) - { - Symbol var = checkSymbol(names.car()); - declareSpecial(var); - names = ((Cons)names).cdr; - } - } - decls = ((Cons)decls).cdr; - } - body = ((Cons)body).cdr; - } - else - break; - } - return body; + LispObject bodyAndDecls = parseBody(body, false); + LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); + for (; specials != NIL; specials = specials.cdr()) + declareSpecial(checkSymbol(specials.car())); + + return bodyAndDecls.car(); } public void declareSpecial(Symbol var) 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 Apr 20 16:21:37 2009 @@ -546,6 +546,59 @@ return thread.execute(function, array); } + public static final LispObject parseBody(LispObject body, + boolean documentationAllowed) + throws ConditionThrowable + { + LispObject decls = NIL; + LispObject doc = NIL; + + while (body != NIL) { + LispObject form = body.car(); + if (documentationAllowed && form instanceof AbstractString + && body.cdr() != NIL) { + doc = body.car(); + documentationAllowed = false; + } else if (form instanceof Cons && form.car() == Symbol.DECLARE) + decls = new Cons(form, decls); + else + break; + + body = body.cdr(); + } + return list(body, decls.nreverse(), doc); + } + + public static final LispObject parseSpecials(LispObject forms) + throws ConditionThrowable + { + LispObject specials = NIL; + while (forms != NIL) { + LispObject decls = forms.car(); + + Debug.assertTrue(decls instanceof Cons); + Debug.assertTrue(decls.car() == Symbol.DECLARE); + decls = decls.cdr(); + while (decls != NIL) { + LispObject decl = decls.car(); + + if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) { + decl = decl.cdr(); + while (decl != NIL) { + specials = new Cons(checkSymbol(decl.car()), specials); + decl = decl.cdr(); + } + } + + decls = decls.cdr(); + } + + forms = forms.cdr(); + } + + return specials; + } + public static final LispObject progn(LispObject body, Environment env, LispThread thread) throws ConditionThrowable @@ -560,22 +613,24 @@ } // Environment wrappers. - private static final boolean isSpecial(Symbol sym, Symbol[] ownSpecials, + private static final boolean isSpecial(Symbol sym, LispObject ownSpecials, Environment env) + throws ConditionThrowable { if (ownSpecials != null) { if (sym.isSpecialVariable()) return true; - for (Symbol special : ownSpecials) + for (; ownSpecials != NIL; ownSpecials = ownSpecials.cdr()) { - if (sym == special) + if (sym == ownSpecials.car()) return true; } } return false; } - protected static final void bindArg(Symbol[] ownSpecials, + + protected static final void bindArg(LispObject ownSpecials, Symbol sym, LispObject value, Environment env, LispThread thread) throws ConditionThrowable 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 Mon Apr 20 16:21:37 2009 @@ -3746,32 +3746,10 @@ values[0] = value; } // Process declarations. - LispObject specials = NIL; - while (body != NIL) - { - LispObject obj = body.car(); - if (obj instanceof Cons && ((Cons)obj).car == Symbol.DECLARE) - { - LispObject decls = ((Cons)obj).cdr; - while (decls != NIL) - { - LispObject decl = decls.car(); - if (decl instanceof Cons && ((Cons)decl).car == Symbol.SPECIAL) - { - LispObject declvars = ((Cons)decl).cdr; - while (declvars != NIL) - { - specials = new Cons(declvars.car(), specials); - declvars = ((Cons)declvars).cdr; - } - } - decls = ((Cons)decls).cdr; - } - body = ((Cons)body).cdr; - } - else - break; - } + LispObject bodyAndDecls = parseBody(body, false); + LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); + body = bodyAndDecls.car(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; final Environment ext = new Environment(env); int i = 0; 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 Mon Apr 20 16:21:37 2009 @@ -118,37 +118,12 @@ try { LispObject varList = checkList(args.car()); - LispObject body = args.cdr(); - // Process declarations. - ArrayList specials = new ArrayList(); - while (body != NIL) - { - LispObject obj = body.car(); - if (obj instanceof Cons && ((Cons)obj).car == Symbol.DECLARE) - { - LispObject decls = ((Cons)obj).cdr; - while (decls != NIL) - { - LispObject decl = decls.car(); - if (decl instanceof Cons && ((Cons)decl).car == Symbol.SPECIAL) - { - LispObject vars = ((Cons)decl).cdr; - while (vars != NIL) - { - specials.add(0, (Symbol) vars.car()); - vars = ((Cons)vars).cdr; - } - } - decls = ((Cons)decls).cdr; - } - body = ((Cons)body).cdr; - } - else - break; - } + LispObject bodyAndDecls = parseBody(args.cdr(), false); + LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); + LispObject body = bodyAndDecls.car(); + Environment ext = new Environment(env); LinkedList nonSequentialVars = new LinkedList(); - Symbol[] arrayToUseForSpecials = new Symbol[0]; while (varList != NIL) { final Symbol symbol; @@ -169,28 +144,22 @@ value = NIL; } if (sequential) - bindArg(specials.toArray(arrayToUseForSpecials), - symbol, value, ext, thread); + bindArg(specials, symbol, value, ext, thread); else nonSequentialVars.add(new Cons(symbol, value)); varList = ((Cons)varList).cdr; } if (!sequential) - { - for (Cons x : nonSequentialVars) - { - bindArg(specials.toArray(arrayToUseForSpecials), - (Symbol)x.car(), x.cdr(), ext, thread); - } - } + for (Cons x : nonSequentialVars) + bindArg(specials, (Symbol)x.car(), x.cdr(), ext, thread); + // Make sure free special declarations are visible in the body. // "The scope of free declarations specifically does not include // initialization forms for bindings established by the form // containing the declarations." (3.3.4) - for (Symbol symbol : specials) - { - ext.declareSpecial(symbol); - } + for (; specials != NIL; specials = specials.cdr()) + ext.declareSpecial((Symbol)specials.car()); + return progn(body, ext, thread); } finally 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 Mon Apr 20 16:21:37 2009 @@ -54,32 +54,10 @@ SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; final LispObject stack = thread.getStack(); // Process declarations. - LispObject specials = NIL; - while (bodyForm != NIL) - { - LispObject obj = bodyForm.car(); - if (obj instanceof Cons && obj.car() == Symbol.DECLARE) - { - LispObject decls = obj.cdr(); - while (decls != NIL) - { - LispObject decl = decls.car(); - if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) - { - LispObject vars = decl.cdr(); - while (vars != NIL) - { - specials = new Cons(vars.car(), specials); - vars = vars.cdr(); - } - } - decls = decls.cdr(); - } - bodyForm = bodyForm.cdr(); - } - else - break; - } + LispObject bodyAndDecls = parseBody(bodyForm, false); + LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); + bodyForm = bodyAndDecls.car(); + try { final Environment ext = new Environment(env); 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 Mon Apr 20 16:21:37 2009 @@ -52,33 +52,11 @@ LispObject resultForm = args.cdr().cdr().car(); SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; final LispObject stack = thread.getStack(); - // Process declarations. - LispObject specials = NIL; - while (bodyForm != NIL) - { - LispObject obj = bodyForm.car(); - if (obj instanceof Cons && obj.car() == Symbol.DECLARE) - { - LispObject decls = obj.cdr(); - while (decls != NIL) - { - LispObject decl = decls.car(); - if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) - { - LispObject vars = decl.cdr(); - while (vars != NIL) - { - specials = new Cons(vars.car(), specials); - vars = vars.cdr(); - } - } - decls = decls.cdr(); - } - bodyForm = bodyForm.cdr(); - } - else - break; - } + + LispObject bodyAndDecls = parseBody(bodyForm, false); + LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); + bodyForm = bodyAndDecls.car(); + try { LispObject limit = eval(countForm, env, thread); From ehuelsmann at common-lisp.net Tue Apr 21 17:26:04 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 21 Apr 2009 13:26:04 -0400 Subject: [armedbear-cvs] r11773 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Apr 21 13:26:02 2009 New Revision: 11773 Log: Fix MULTIPLE-VALUE-SETQ and (SETF (VALUES ...) ...) when setting the value of symbol macros. Fixes MULTIPLE-VALUE-SETQ.5 and MULTIPLE-VALUE-SETQ.8. Modified: trunk/abcl/src/org/armedbear/lisp/setf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/setf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/setf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/setf.lisp Tue Apr 21 13:26:02 2009 @@ -63,9 +63,13 @@ (resolve (%car form))) (let (temp) (cond ((symbolp form) - (let ((new-var (gensym))) - (values nil nil (list new-var) - `(setq ,form ,new-var) form))) + (multiple-value-bind (expansion expanded) + (macroexpand-1 form environment) + (if expanded + (get-setf-expansion expansion environment) + (let ((new-var (gensym))) + (values nil nil (list new-var) + `(setq ,form ,new-var) form))))) ((setq temp (get (car form) 'setf-inverse)) (get-setf-method-inverse form `(,temp) nil)) ((setq temp (get (car form) 'setf-expander)) From ehuelsmann at common-lisp.net Tue Apr 21 19:34:40 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 21 Apr 2009 15:34:40 -0400 Subject: [armedbear-cvs] r11774 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Apr 21 15:34:38 2009 New Revision: 11774 Log: Fix DEFINE-SETF-EXPANDER.1 by returning the symbol passed in ACCESS-FN. Modified: trunk/abcl/src/org/armedbear/lisp/late-setf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/late-setf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/late-setf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/late-setf.lisp Tue Apr 21 15:34:38 2009 @@ -41,10 +41,12 @@ (parse-defmacro lambda-list whole body access-fn 'define-setf-expander :environment environment) - `(setf (get ',access-fn 'setf-expander) + `(progn + (setf (get ',access-fn 'setf-expander) #'(lambda (,whole ,environment) , at local-decs - (block ,access-fn ,body)))))) + (block ,access-fn ,body))) + ',access-fn)))) (define-setf-expander values (&rest places &environment env) (let ((setters ()) From ehuelsmann at common-lisp.net Tue Apr 21 20:00:59 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 21 Apr 2009 16:00:59 -0400 Subject: [armedbear-cvs] r11775 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Apr 21 16:00:59 2009 New Revision: 11775 Log: Fix the remaining two DEFINE-SETF-EXPANDER tests (.6 and ??). Modified: trunk/abcl/src/org/armedbear/lisp/late-setf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/late-setf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/late-setf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/late-setf.lisp Tue Apr 21 16:00:59 2009 @@ -42,6 +42,8 @@ 'define-setf-expander :environment environment) `(progn + ,@(when doc + `((%set-documentation ',access-fn 'setf ,doc))) (setf (get ',access-fn 'setf-expander) #'(lambda (,whole ,environment) , at local-decs From ehuelsmann at common-lisp.net Tue Apr 21 20:56:12 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 21 Apr 2009 16:56:12 -0400 Subject: [armedbear-cvs] r11776 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Apr 21 16:56:11 2009 New Revision: 11776 Log: Fix DO-ALL-SYMBOLS.{6,9,12}: we can't use DOLIST, because it has an implicit NIL block surrounding it. MAPC doesn't. Modified: trunk/abcl/src/org/armedbear/lisp/do-all-symbols.lisp Modified: trunk/abcl/src/org/armedbear/lisp/do-all-symbols.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/do-all-symbols.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/do-all-symbols.lisp Tue Apr 21 16:56:11 2009 @@ -40,12 +40,14 @@ (flet ((,flet-name (,var) , at decls (tagbody , at forms))) - (dolist (package (list-all-packages)) - (flet ((iterate-over-symbols (symbols) - (dolist (symbol symbols) - (,flet-name symbol)))) - (iterate-over-symbols (package-internal-symbols package)) - (iterate-over-symbols (package-external-symbols package))))) + (mapc #'(lambda (package) + (flet ((iterate-over-symbols (symbols) + (mapc #',flet-name symbols))) + (iterate-over-symbols + (package-internal-symbols package)) + (iterate-over-symbols + (package-external-symbols package)))) + (list-all-packages))) (let ((,var nil)) (declare (ignorable ,var)) , at decls From ehuelsmann at common-lisp.net Wed Apr 22 19:02:15 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 22 Apr 2009 15:02:15 -0400 Subject: [armedbear-cvs] r11777 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 22 15:02:12 2009 New Revision: 11777 Log: Put special bindings restoration-to-old-value in a FINALLY clause at the end of the block. Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/UnboundVariable.java Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Wed Apr 22 15:02:12 2009 @@ -627,234 +627,238 @@ Environment ext = new Environment(environment); // Section 3.4.4: "...the &environment parameter is bound along with // &whole before any other variables in the lambda list..." - if (bindInitForms) - if (envVar != null) - bindArg(specials, envVar, environment, ext, thread); - // Required parameters. - for (int i = 0; i < minArgs; i++) - { + try { if (bindInitForms) - bindArg(specials, requiredParameters[i].var, args[i], ext, thread); - array[index++] = args[i]; - } - int i = minArgs; - int argsUsed = minArgs; - // Optional parameters. - for (Parameter parameter : optionalParameters) - { - if (i < argsLength) + if (envVar != null) + bindArg(specials, envVar, environment, ext, thread); + // Required parameters. + for (int i = 0; i < minArgs; i++) { if (bindInitForms) - bindArg(specials, parameter.var, args[i], ext, thread); + bindArg(specials, requiredParameters[i].var, args[i], ext, thread); array[index++] = args[i]; - ++argsUsed; - if (parameter.svar != NIL) - { - if (bindInitForms) - bindArg(specials, (Symbol)parameter.svar, T, ext, thread); - array[index++] = T; - } } - else + int i = minArgs; + int argsUsed = minArgs; + // Optional parameters. + for (Parameter parameter : optionalParameters) { - // We've run out of arguments. - LispObject value; - if (parameter.initVal != null) - value = parameter.initVal; - else - value = eval(parameter.initForm, ext, thread); - if (bindInitForms) - bindArg(specials, parameter.var, value, ext, thread); - array[index++] = value; - if (parameter.svar != NIL) + if (i < argsLength) { if (bindInitForms) - bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); - array[index++] = NIL; + bindArg(specials, parameter.var, args[i], ext, thread); + array[index++] = args[i]; + ++argsUsed; + if (parameter.svar != NIL) + { + if (bindInitForms) + bindArg(specials, (Symbol)parameter.svar, T, ext, thread); + array[index++] = T; + } } - } - ++i; - } - // &rest parameter. - if (restVar != null) - { - LispObject rest = NIL; - for (int j = argsLength; j-- > argsUsed;) - rest = new Cons(args[j], rest); - if (bindInitForms) - bindArg(specials, restVar, rest, ext, thread); - array[index++] = rest; - } - // Keyword parameters. - if (keywordParameters.length > 0) - { - int argsLeft = argsLength - argsUsed; - if (argsLeft == 0) - { - // No keyword arguments were supplied. - // Bind all keyword parameters to their defaults. - for (int k = 0; k < keywordParameters.length; k++) + else { - Parameter parameter = keywordParameters[k]; + // We've run out of arguments. LispObject value; if (parameter.initVal != null) value = parameter.initVal; else value = eval(parameter.initForm, ext, thread); if (bindInitForms) - bindArg(specials, parameter.var, value, ext, thread); + bindArg(specials, parameter.var, value, ext, thread); array[index++] = value; if (parameter.svar != NIL) { if (bindInitForms) - bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); + bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); array[index++] = NIL; } } + ++i; } - else + // &rest parameter. + if (restVar != null) { - if ((argsLeft % 2) != 0) - error(new ProgramError("Odd number of keyword arguments.")); - LispObject allowOtherKeysValue = null; - for (Parameter parameter : keywordParameters) + LispObject rest = NIL; + for (int j = argsLength; j-- > argsUsed;) + rest = new Cons(args[j], rest); + if (bindInitForms) + bindArg(specials, restVar, rest, ext, thread); + array[index++] = rest; + } + // Keyword parameters. + if (keywordParameters.length > 0) + { + int argsLeft = argsLength - argsUsed; + if (argsLeft == 0) { - Symbol keyword = parameter.keyword; - LispObject value = null; - boolean unbound = true; - for (int j = argsUsed; j < argsLength; j += 2) - { - if (args[j] == keyword) - { - if (bindInitForms) - bindArg(specials, parameter.var, args[j+1], ext, thread); - value = array[index++] = args[j+1]; - if (parameter.svar != NIL) - { - if (bindInitForms) - bindArg(specials,(Symbol)parameter.svar, T, ext, thread); - array[index++] = T; - } - args[j] = null; - args[j+1] = null; - unbound = false; - break; - } - } - if (unbound) + // No keyword arguments were supplied. + // Bind all keyword parameters to their defaults. + for (int k = 0; k < keywordParameters.length; k++) { + Parameter parameter = keywordParameters[k]; + LispObject value; if (parameter.initVal != null) value = parameter.initVal; else value = eval(parameter.initForm, ext, thread); if (bindInitForms) - bindArg(specials, parameter.var, value, ext, thread); + bindArg(specials, parameter.var, value, ext, thread); array[index++] = value; if (parameter.svar != NIL) { if (bindInitForms) - bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); + bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); array[index++] = NIL; } } - if (keyword == Keyword.ALLOW_OTHER_KEYS) - { - if (allowOtherKeysValue == null) - allowOtherKeysValue = value; - } } - if (!allowOtherKeys) + else { - if (allowOtherKeysValue == null || allowOtherKeysValue == NIL) + if ((argsLeft % 2) != 0) + error(new ProgramError("Odd number of keyword arguments.")); + LispObject allowOtherKeysValue = null; + for (Parameter parameter : keywordParameters) { - LispObject unrecognizedKeyword = null; + Symbol keyword = parameter.keyword; + LispObject value = null; + boolean unbound = true; for (int j = argsUsed; j < argsLength; j += 2) { - LispObject keyword = args[j]; - if (keyword == null) - continue; - if (keyword == Keyword.ALLOW_OTHER_KEYS) + if (args[j] == keyword) { - if (allowOtherKeysValue == null) + if (bindInitForms) + bindArg(specials, parameter.var, args[j+1], ext, thread); + value = array[index++] = args[j+1]; + if (parameter.svar != NIL) { - allowOtherKeysValue = args[j+1]; - if (allowOtherKeysValue != NIL) - break; + if (bindInitForms) + bindArg(specials,(Symbol)parameter.svar, T, ext, thread); + array[index++] = T; } - continue; + args[j] = null; + args[j+1] = null; + unbound = false; + break; } - // Unused keyword argument. - boolean ok = false; - for (Parameter parameter : keywordParameters) + } + if (unbound) + { + if (parameter.initVal != null) + value = parameter.initVal; + else + value = eval(parameter.initForm, ext, thread); + if (bindInitForms) + bindArg(specials, parameter.var, value, ext, thread); + array[index++] = value; + if (parameter.svar != NIL) { - if (parameter.keyword == keyword) - { - // Found it! - ok = true; - break; - } + if (bindInitForms) + bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); + array[index++] = NIL; } - if (ok) - continue; - // Unrecognized keyword argument. - if (unrecognizedKeyword == null) - unrecognizedKeyword = keyword; } - if (unrecognizedKeyword != null) + if (keyword == Keyword.ALLOW_OTHER_KEYS) { - if (!allowOtherKeys && - (allowOtherKeysValue == null || allowOtherKeysValue == NIL)) - error(new ProgramError("Unrecognized keyword argument " + - unrecognizedKeyword.writeToString())); + if (allowOtherKeysValue == null) + allowOtherKeysValue = value; + } + } + if (!allowOtherKeys) + { + if (allowOtherKeysValue == null || allowOtherKeysValue == NIL) + { + LispObject unrecognizedKeyword = null; + for (int j = argsUsed; j < argsLength; j += 2) + { + LispObject keyword = args[j]; + if (keyword == null) + continue; + if (keyword == Keyword.ALLOW_OTHER_KEYS) + { + if (allowOtherKeysValue == null) + { + allowOtherKeysValue = args[j+1]; + if (allowOtherKeysValue != NIL) + break; + } + continue; + } + // Unused keyword argument. + boolean ok = false; + for (Parameter parameter : keywordParameters) + { + if (parameter.keyword == keyword) + { + // Found it! + ok = true; + break; + } + } + if (ok) + continue; + // Unrecognized keyword argument. + if (unrecognizedKeyword == null) + unrecognizedKeyword = keyword; + } + if (unrecognizedKeyword != null) + { + if (!allowOtherKeys && + (allowOtherKeysValue == null || allowOtherKeysValue == NIL)) + error(new ProgramError("Unrecognized keyword argument " + + unrecognizedKeyword.writeToString())); + } } } } } - } - else if (argsUsed < argsLength) - { - // No keyword parameters. - if (argsUsed + 2 <= argsLength) + else if (argsUsed < argsLength) { - // Check for :ALLOW-OTHER-KEYS. - LispObject allowOtherKeysValue = NIL; - int n = argsUsed; - while (n < argsLength) + // No keyword parameters. + if (argsUsed + 2 <= argsLength) { - LispObject keyword = args[n]; - if (keyword == Keyword.ALLOW_OTHER_KEYS) + // Check for :ALLOW-OTHER-KEYS. + LispObject allowOtherKeysValue = NIL; + int n = argsUsed; + while (n < argsLength) { - allowOtherKeysValue = args[n+1]; - break; + LispObject keyword = args[n]; + if (keyword == Keyword.ALLOW_OTHER_KEYS) + { + allowOtherKeysValue = args[n+1]; + break; + } + n += 2; } - n += 2; - } - if (allowOtherKeys || allowOtherKeysValue != NIL) - { - // Skip keyword/value pairs. - while (argsUsed + 2 <= argsLength) - argsUsed += 2; - } - else if (andKey) - { - LispObject keyword = args[argsUsed]; - if (keyword == Keyword.ALLOW_OTHER_KEYS) + if (allowOtherKeys || allowOtherKeysValue != NIL) { - // Section 3.4.1.4: "Note that if &KEY is present, a - // keyword argument of :ALLOW-OTHER-KEYS is always - // permitted---regardless of whether the associated - // value is true or false." - argsUsed += 2; + // Skip keyword/value pairs. + while (argsUsed + 2 <= argsLength) + argsUsed += 2; + } + else if (andKey) + { + LispObject keyword = args[argsUsed]; + if (keyword == Keyword.ALLOW_OTHER_KEYS) + { + // Section 3.4.1.4: "Note that if &KEY is present, a + // keyword argument of :ALLOW-OTHER-KEYS is always + // permitted---regardless of whether the associated + // value is true or false." + argsUsed += 2; + } } } + if (argsUsed < argsLength) + { + if (restVar == null) + error(new WrongNumberOfArgumentsException(this)); + } } - if (argsUsed < argsLength) - { - if (restVar == null) - error(new WrongNumberOfArgumentsException(this)); - } - } - thread.lastSpecialBinding = lastSpecialBinding; + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } return array; } 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 Apr 22 15:02:12 2009 @@ -1795,8 +1795,12 @@ LispObject obj = args[j++]; SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; thread.bindSpecial(Symbol.PRINT_ESCAPE, T); - sb.append(obj.writeToString()); - thread.lastSpecialBinding = lastSpecialBinding; + try { + sb.append(obj.writeToString()); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } } } else if (c == 'D' || c == 'd') @@ -1808,8 +1812,12 @@ thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); thread.bindSpecial(Symbol.PRINT_RADIX, NIL); thread.bindSpecial(Symbol.PRINT_BASE, Fixnum.constants[10]); - sb.append(obj.writeToString()); - thread.lastSpecialBinding = lastSpecialBinding; + try { + sb.append(obj.writeToString()); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } } } else if (c == 'X' || c == 'x') @@ -1821,8 +1829,12 @@ thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); thread.bindSpecial(Symbol.PRINT_RADIX, NIL); thread.bindSpecial(Symbol.PRINT_BASE, Fixnum.constants[16]); - sb.append(obj.writeToString()); - thread.lastSpecialBinding = lastSpecialBinding; + try { + sb.append(obj.writeToString()); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } } } else if (c == '%') Modified: trunk/abcl/src/org/armedbear/lisp/UnboundVariable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/UnboundVariable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/UnboundVariable.java Wed Apr 22 15:02:12 2009 @@ -58,8 +58,10 @@ sb.append(getCellName().writeToString()); } catch (Throwable t) {} + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } sb.append(" is unbound."); - thread.lastSpecialBinding = lastSpecialBinding; return sb.toString(); } From vvoutilainen at common-lisp.net Thu Apr 23 20:46:30 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Thu, 23 Apr 2009 16:46:30 -0400 Subject: [armedbear-cvs] r11778 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Thu Apr 23 16:46:27 2009 New Revision: 11778 Log: Fix declaration of free specials for non-array execute. Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Thu Apr 23 16:46:27 2009 @@ -398,6 +398,7 @@ bindParameterDefaults(keywordParameters, ext, thread); } bindAuxVars(ext, thread); + declareFreeSpecials(ext); try { return progn(executionBody, ext, thread); @@ -558,6 +559,24 @@ } } + private final void declareFreeSpecials(Environment ext) + throws ConditionThrowable + { + LispObject s = specials; + special: + while (s != NIL) { + Symbol special = (Symbol)s.car(); + s = s.cdr(); + for (Symbol var : variables) + if (special == var) + continue special; + for (Parameter parameter : auxVars) + if (special == parameter.var) + continue special; + ext.declareSpecial(special); + } + } + @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { @@ -579,19 +598,7 @@ bindArg(specials, sym, args[i], ext, thread); } bindAuxVars(ext, thread); - LispObject s = specials; - special: - while (s != NIL) { - Symbol special = (Symbol)s.car(); - s = s.cdr(); - for (Symbol var : variables) - if (special == var) - continue special; - for (Parameter parameter : auxVars) - if (special == parameter.var) - continue special; - ext.declareSpecial(special); - } + declareFreeSpecials(ext); try { return progn(executionBody, ext, thread); From mevenson at common-lisp.net Fri Apr 24 12:34:53 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 24 Apr 2009 08:34:53 -0400 Subject: [armedbear-cvs] r11779 - trunk/abcl Message-ID: Author: mevenson Date: Fri Apr 24 08:34:47 2009 New Revision: 11779 Log: Fix broken ansi-interpreted test invocation. Modified: trunk/abcl/abcl.asd Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Fri Apr 24 08:34:47 2009 @@ -37,7 +37,7 @@ (defmethod perform ((o test-op) (c (eql (find-system 'ansi-interpreted)))) "Invoke tests with: (asdf:oos 'asdf:test-op :ansi-interpreted :force t)." ;;; FIXME needs ASDF:OOS to be invoked with :FORCE t - (funcall (intern (symbol-name 'run) :ansi.test.ansi) + (funcall (intern (symbol-name 'run) :abcl.test.ansi) :compile-tests nil)) (defsystem :ansi-compiled :version "1.0" :depends-on (ansi-test)) From ehuelsmann at common-lisp.net Fri Apr 24 19:51:49 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 24 Apr 2009 15:51:49 -0400 Subject: [armedbear-cvs] r11780 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Apr 24 15:51:45 2009 New Revision: 11780 Log: Clean up the known symbols cache: * instead of returning only the name of the field, also return the containing class * unify the SYMBOLS and KEYWORDS hashes into a single hash allowing extension when required * enlarge the symbols cache: there were 1057 symbols to be stored in a hash of 1024 initial size Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/known-symbols.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 Apr 24 15:51:45 2009 @@ -2957,9 +2957,11 @@ (declare-object op)))) (emit 'getstatic *this-class* g +lisp-object+))) (t - (let ((name (lookup-known-symbol op))) + (multiple-value-bind + (name class) + (lookup-known-symbol op) (if name - (emit 'getstatic +lisp-symbol-class+ name +lisp-symbol+) + (emit 'getstatic class name +lisp-symbol+) (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+))))) (process-args args) (if (or (<= *speed* *debug*) *require-stack-frame*) @@ -4921,18 +4923,15 @@ ((eq representation :boolean) (emit 'iconst_1) (emit-move-from-stack target representation)) - ((keywordp obj) - (let ((name (lookup-known-keyword obj))) - (if name - (emit 'getstatic "org/armedbear/lisp/Keyword" name +lisp-symbol+) - (emit 'getstatic *this-class* (declare-keyword obj) +lisp-symbol+))) - (emit-move-from-stack target representation)) ((symbolp obj) - (let ((name (lookup-known-symbol obj))) + (multiple-value-bind + (name class) + (lookup-known-symbol obj) (cond (name - (emit 'getstatic +lisp-symbol-class+ name +lisp-symbol+)) + (emit 'getstatic class name +lisp-symbol+)) ((symbol-package (truly-the symbol obj)) - (emit 'getstatic *this-class* (declare-symbol obj) +lisp-symbol+)) + (emit 'getstatic *this-class* (declare-symbol obj) + +lisp-symbol+)) (t ;; An uninterned symbol. (let ((g (if *file-compilation* @@ -8008,10 +8007,13 @@ (:boolean (emit 'iconst_1)) ((nil) - (let ((name (lookup-known-keyword form))) + (multiple-value-bind + (name class) + (lookup-known-symbol form) (if name - (emit 'getstatic "org/armedbear/lisp/Keyword" name +lisp-symbol+) - (emit 'getstatic *this-class* (declare-keyword form) +lisp-symbol+))))) + (emit 'getstatic class name +lisp-symbol+) + (emit 'getstatic *this-class* (declare-keyword form) + +lisp-symbol+))))) (emit-move-from-stack target representation)) (t ;; Shouldn't happen. 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 Fri Apr 24 15:51:45 2009 @@ -31,13 +31,12 @@ (in-package #:system) -(export '(lookup-known-symbol lookup-known-keyword)) +(export '(lookup-known-symbol)) -(let ((symbols (make-hash-table :test 'eq :size 1024)) - (keywords (make-hash-table :test 'eq :size 128))) +(let ((symbols (make-hash-table :test 'eq :size 2048))) (defun initialize-known-symbols (source ht) - (clrhash ht) (let* ((source-class (java:jclass source)) + (class-designator (substitute #\/ #\. source)) (symbol-class (java:jclass "org.armedbear.lisp.Symbol")) (fields (java:jclass-fields source-class :declared t :public t))) (dotimes (i (length fields)) @@ -46,16 +45,16 @@ (when (equal type symbol-class) (let* ((name (java:jfield-name field)) (symbol (java:jfield source-class name))) - (puthash symbol ht name)))))) + (puthash symbol ht (list name class-designator))))))) (hash-table-count ht)) (initialize-known-symbols "org.armedbear.lisp.Symbol" symbols) - (initialize-known-symbols "org.armedbear.lisp.Keyword" keywords) + (initialize-known-symbols "org.armedbear.lisp.Keyword" symbols) (defun lookup-known-symbol (symbol) - (gethash1 symbol symbols)) + "Returns the name of the field and its class designator +which stores the Java object `symbol'." + (values-list (gethash1 symbol symbols)))) - (defun lookup-known-keyword (keyword) - (gethash1 keyword keywords))) (provide '#:known-symbols) From ehuelsmann at common-lisp.net Sat Apr 25 05:42:31 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 25 Apr 2009 01:42:31 -0400 Subject: [armedbear-cvs] r11781 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Apr 25 01:42:28 2009 New Revision: 11781 Log: Instead of interning symbols over and over, use the ones already interned. 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 Apr 25 01:42:28 2009 @@ -746,8 +746,10 @@ (emit 'aaload)))) (defun emit-push-variable-name (variable) - (emit 'getstatic *this-class* (declare-symbol (variable-name variable)) - +lisp-symbol+)) + (multiple-value-bind + (name class) + (lookup-or-declare-symbol (variable-name variable)) + (emit 'getstatic class name +lisp-symbol+))) (defknown generate-instanceof-type-check-for-variable (t t) t) (defun generate-instanceof-type-check-for-variable (variable expected-type) @@ -2038,6 +2040,16 @@ (setf *static-code* *code*) (setf (gethash symbol ht) g)))))) +(defun lookup-or-declare-symbol (symbol) + "Returns the value-pair (VALUES field class) from which +the Java object representing SYMBOL can be retrieved." + (multiple-value-bind + (name class) + (lookup-known-symbol symbol) + (if name + (values name class) + (values (declare-symbol symbol) *this-class*)))) + (defknown declare-keyword (symbol) string) (defun declare-keyword (symbol) (declare (type symbol symbol)) @@ -2062,22 +2074,17 @@ (let ((s (sanitize symbol))) (when s (setf f (concatenate 'string f "_" s)))) - (let ((*code* *static-code*) - (g (gethash1 symbol (the hash-table *declared-symbols*)))) - (cond (g - (emit 'getstatic *this-class* g +lisp-symbol+)) - (t - (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+))) - (declare-field f +lisp-object+) - (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie" - nil +lisp-object+) - (emit 'putstatic *this-class* f +lisp-object+) - (setf *static-code* *code*) - (setf (gethash symbol ht) f)))) + (declare-field f +lisp-object+) + (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+ "getSymbolFunctionOrDie" + nil +lisp-object+) + (emit 'putstatic *this-class* f +lisp-object+) + (setf *static-code* *code*) + (setf (gethash symbol ht) f))))) (defknown declare-setf-function (name) string) (defun declare-setf-function (name) @@ -2089,22 +2096,17 @@ (let ((s (sanitize symbol))) (when s (setf f (concatenate 'string f "_SETF_" s)))) - (let ((*code* *static-code*) - (g (gethash1 symbol (the hash-table *declared-symbols*)))) - (cond (g - (emit 'getstatic *this-class* g +lisp-symbol+)) - (t - (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+))) - (declare-field f +lisp-object+) - (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie" - nil +lisp-object+) - (emit 'putstatic *this-class* f +lisp-object+) - (setf *static-code* *code*) - (setf (gethash name ht) f))))) + (multiple-value-bind + (name class) + (lookup-or-declare-symbol symbol) + (let ((*code* *static-code*)) + (emit 'getstatic class name +lisp-symbol+) + (declare-field f +lisp-object+) + (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie" + nil +lisp-object+) + (emit 'putstatic *this-class* f +lisp-object+) + (setf *static-code* *code*) + (setf (gethash name ht) f)))))) (defknown declare-local-function (local-function) string) @@ -2949,20 +2951,16 @@ (emit-push-current-thread)) (cond ((eq op (compiland-name *current-compiland*)) ; recursive call (if (notinline-p op) - (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+) + (multiple-value-bind + (name class) + (lookup-or-declare-symbol op) + (emit 'getstatic class name +lisp-symbol+)) (aload 0))) - ((null (symbol-package op)) - (let ((g (if *file-compilation* - (declare-object-as-string op) - (declare-object op)))) - (emit 'getstatic *this-class* g +lisp-object+))) (t (multiple-value-bind (name class) - (lookup-known-symbol op) - (if name - (emit 'getstatic class name +lisp-symbol+) - (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+))))) + (lookup-or-declare-symbol op) + (emit 'getstatic class name +lisp-symbol+)))) (process-args args) (if (or (<= *speed* *debug*) *require-stack-frame*) (emit-call-thread-execute numargs) @@ -4926,19 +4924,9 @@ ((symbolp obj) (multiple-value-bind (name class) - (lookup-known-symbol obj) - (cond (name - (emit 'getstatic class name +lisp-symbol+)) - ((symbol-package (truly-the symbol obj)) - (emit 'getstatic *this-class* (declare-symbol obj) - +lisp-symbol+)) - (t - ;; An uninterned symbol. - (let ((g (if *file-compilation* - (declare-object-as-string obj) - (declare-object obj)))) - (emit 'getstatic *this-class* g +lisp-object+)))) - (emit-move-from-stack target representation))) + (lookup-or-declare-symbol obj) + (emit 'getstatic class name +lisp-symbol+)) + (emit-move-from-stack target representation)) ((listp obj) (let ((g (if *file-compilation* (declare-object-as-string obj) @@ -5190,9 +5178,12 @@ (declare-function name) +lisp-object+) (emit-move-from-stack target)) (t - (emit 'getstatic *this-class* - (declare-symbol name) +lisp-symbol+) - (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie" + (multiple-value-bind + (name class) + (lookup-or-declare-symbol name) + (emit 'getstatic class name +lisp-symbol+)) + (emit-invokevirtual +lisp-object-class+ + "getSymbolFunctionOrDie" nil +lisp-object+) (emit-move-from-stack target)))) ((and (consp name) (eq (%car name) 'SETF)) @@ -5226,8 +5217,10 @@ (declare-object (fdefinition name)) +lisp-object+) (emit-move-from-stack target)) (t - (emit 'getstatic *this-class* - (declare-symbol (cadr name)) +lisp-symbol+) + (multiple-value-bind + (name class) + (lookup-or-declare-symbol (cadr name)) + (emit 'getstatic class name +lisp-symbol+)) (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie" nil +lisp-object+) @@ -7486,7 +7479,10 @@ (packagep value)) (compile-constant value target representation) (return-from compile-special-reference)))) - (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+) + (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." @@ -7561,7 +7557,10 @@ (return-from p2-setq (compile-form (p1 new-form) target representation)))) ;; We're setting a special variable. (emit-push-current-thread) - (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+) + (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) @@ -8009,11 +8008,8 @@ ((nil) (multiple-value-bind (name class) - (lookup-known-symbol form) - (if name - (emit 'getstatic class name +lisp-symbol+) - (emit 'getstatic *this-class* (declare-keyword form) - +lisp-symbol+))))) + (lookup-or-declare-symbol form) + (emit 'getstatic class name +lisp-symbol+)))) (emit-move-from-stack target representation)) (t ;; Shouldn't happen. From ehuelsmann at common-lisp.net Sat Apr 25 05:56:47 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 25 Apr 2009 01:56:47 -0400 Subject: [armedbear-cvs] r11782 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Apr 25 01:56:46 2009 New Revision: 11782 Log: Remove code duplication. 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 Apr 25 01:56:46 2009 @@ -2065,12 +2065,12 @@ (setf *static-code* *code*) (setf (gethash symbol ht) g)))) -(defknown declare-function (symbol) string) -(defun declare-function (symbol) +(defknown declare-function (symbol &optional setf) string) +(defun declare-function (symbol &optional setf) (declare (type symbol symbol)) (declare-with-hashtable symbol *declared-functions* ht f - (setf f (symbol-name (gensym "FUN"))) + (setf f (symbol-name (if setf (gensym "SETF") (gensym "FUN")))) (let ((s (sanitize symbol))) (when s (setf f (concatenate 'string f "_" s)))) @@ -2080,7 +2080,10 @@ (lookup-or-declare-symbol symbol) (let ((*code* *static-code*)) (emit 'getstatic class name +lisp-symbol+) - (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie" + (emit-invokevirtual +lisp-symbol-class+ + (if setf + "getSymbolSetfFunctionOrDie" + "getSymbolFunctionOrDie") nil +lisp-object+) (emit 'putstatic *this-class* f +lisp-object+) (setf *static-code* *code*) @@ -2088,25 +2091,7 @@ (defknown declare-setf-function (name) string) (defun declare-setf-function (name) - (declare-with-hashtable - name *declared-functions* ht f - (let ((symbol (cadr name))) - (declare (type symbol symbol)) - (setf f (symbol-name (gensym))) - (let ((s (sanitize symbol))) - (when s - (setf f (concatenate 'string f "_SETF_" s)))) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol symbol) - (let ((*code* *static-code*)) - (emit 'getstatic class name +lisp-symbol+) - (declare-field f +lisp-object+) - (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie" - nil +lisp-object+) - (emit 'putstatic *this-class* f +lisp-object+) - (setf *static-code* *code*) - (setf (gethash name ht) f)))))) + (declare-function (cadr name) t)) (defknown declare-local-function (local-function) string) From ehuelsmann at common-lisp.net Sat Apr 25 14:19:54 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 25 Apr 2009 10:19:54 -0400 Subject: [armedbear-cvs] r11783 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Apr 25 10:19:51 2009 New Revision: 11783 Log: Fix fasl reader special bindings leak. * Bind the *FASL-ANONYMOUS-PACKAGE* to the outer most scope which needs one, instead of binding it upon first use. Specials shouldn't be bound with indefinite extent: some other code might limit the extent by unbinding its specials. Modified: trunk/abcl/src/org/armedbear/lisp/FaslReader.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Primitives.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 trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/FaslReader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslReader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslReader.java Sat Apr 25 10:19:51 2009 @@ -284,10 +284,7 @@ LispThread thread = LispThread.currentThread(); Symbol symbol = (Symbol) stream.readSymbol(FaslReadtable.getInstance()); LispObject pkg = Load._FASL_ANONYMOUS_PACKAGE_.symbolValue(thread); - if (pkg == NIL) { - thread.bindSpecial(Load._FASL_ANONYMOUS_PACKAGE_, - pkg = new Package()); - } + Debug.assertTrue(pkg != NIL); symbol = ((Package)pkg).intern(symbol.getName()); symbol.setPackage(NIL); return symbol; Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sat Apr 25 10:19:51 2009 @@ -344,6 +344,11 @@ // ### *fasl-anonymous-package* // internal symbol + /** + * This variable gets bound to a package with no name in which the + * reader can intern its uninterned symbols. + * + */ public static final Symbol _FASL_ANONYMOUS_PACKAGE_ = internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL); @@ -473,11 +478,18 @@ { Stream in = (Stream) _LOAD_STREAM_.symbolValue(thread); final Environment env = new Environment(); - while (true) { - LispObject obj = in.faslRead(false, EOF, true, thread); - if (obj == EOF) - break; - eval(obj, env, thread); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + try { + thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package()); + while (true) { + LispObject obj = in.faslRead(false, EOF, true, thread); + if (obj == EOF) + break; + eval(obj, env, thread); + } + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; } return T; } Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat Apr 25 10:19:51 2009 @@ -3017,6 +3017,20 @@ private static final Primitive _MAKE_PACKAGE = new Primitive("%make-package", PACKAGE_SYS, false) { + /** + * This invocation is solely used to be able to create + * a package to bind to *FASL-ANONYMOUS-PACKAGE* + */ + @Override + public LispObject execute() + throws ConditionThrowable + { + return new Package(); + } + + /** + * This invocation is used by MAKE-PACKAGE to create a package + */ @Override public LispObject execute(LispObject first, LispObject second, LispObject third) Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Sat Apr 25 10:19:51 2009 @@ -518,8 +518,16 @@ } else { + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); - return faslReadPreservingWhitespace(eofError, eofValue, true, thread); + try + { + return faslReadPreservingWhitespace(eofError, eofValue, true, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } } } 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 Apr 25 10:19:51 2009 @@ -427,7 +427,8 @@ (*debug* *debug*) (*explain* *explain*) (jvm::*functions-defined-in-current-file* '()) - (*fbound-names* '())) + (*fbound-names* '()) + (*fasl-anonymous-package* (%make-package))) (jvm::with-file-compilation (write "; -*- Mode: Lisp -*-" :escape nil :stream out) (%stream-terpri out) 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 Apr 25 10:19:51 2009 @@ -5019,7 +5019,8 @@ pathname class-file lambda-list (set-compiland-and-write-class-file class-file compiland) (setf (local-function-class-file local-function) class-file) - (setf (local-function-function local-function) (load-compiled-function pathname)) + (setf (local-function-function local-function) + (load-compiled-function pathname)) (when (local-function-variable local-function) (let ((g (declare-object (load-compiled-function pathname)))) (emit-make-compiled-closure-for-flet/labels 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 Sat Apr 25 10:19:51 2009 @@ -413,7 +413,8 @@ (defun compile (name &optional definition) (let ((*file-compilation* nil) - (*pathnames-generator* #'make-temp-file)) + (*pathnames-generator* #'make-temp-file) + (sys::*fasl-anonymous-package* (sys::%make-package))) (jvm-compile name definition))) (defmacro with-file-compilation (&body body) From ehuelsmann at common-lisp.net Sun Apr 26 06:49:40 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 26 Apr 2009 02:49:40 -0400 Subject: [armedbear-cvs] r11784 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 26 02:49:37 2009 New Revision: 11784 Log: Add a function which seems to be missing in our sources (MISSING-ARG). Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/format.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/format.lisp Sun Apr 26 02:49:37 2009 @@ -359,6 +359,9 @@ (format-error-control-string condition) (format-error-offset condition))) +(defun missing-arg () + (error "Missing argument in format directive")) + (defstruct format-directive (string (missing-arg) :type simple-string) (start (missing-arg) :type (and unsigned-byte fixnum)) From ehuelsmann at common-lisp.net Sun Apr 26 06:58:47 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 26 Apr 2009 02:58:47 -0400 Subject: [armedbear-cvs] r11785 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 26 02:58:46 2009 New Revision: 11785 Log: Add ignore declaration on unused argument. Modified: trunk/abcl/src/org/armedbear/lisp/restart.lisp Modified: trunk/abcl/src/org/armedbear/lisp/restart.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/restart.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/restart.lisp Sun Apr 26 02:58:46 2009 @@ -47,7 +47,7 @@ function report-function interactive-function - (test-function #'(lambda (c) t))) + (test-function #'(lambda (c) (declare (ignore c)) t))) (defmacro restart-bind (bindings &body forms) `(let ((*restart-clusters* From ehuelsmann at common-lisp.net Sun Apr 26 07:08:44 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 26 Apr 2009 03:08:44 -0400 Subject: [armedbear-cvs] r11786 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 26 03:08:43 2009 New Revision: 11786 Log: Add support for non-constant initforms on functions. This fixes DEFUN.6, DEFUN.7, LABELS.7C and LABELS.7D. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Sun Apr 26 03:08:43 2009 @@ -353,6 +353,7 @@ (declaim (ftype (function (t) t) precompile1)) (defun precompile1 (form) +;; (sys::%format t "~S~%" form) (cond ((symbolp form) (let ((varspec (find-varspec form))) (cond ((and varspec (eq (second varspec) :symbol-macro)) @@ -599,6 +600,30 @@ (rewrite-aux-vars-process-decls decls (lambda-list-names lambda-list) aux-vars) `(lambda ,lambda-list , at lambda-decls (let* ,lets , at let-decls , at body)))))) +#| +(defun split-declarations (related-symbols decls) + "Splits IGNORE, IGNORABLE, DYNAMIC-EXTENT, TYPE, FTYPE and +into the declarations related to `related-symbols' and the rest." + ;; IGNORE, IGNORABLE and DYNAMIC-EXTENT have the same format + (let (related-decls other-decls) + (dolist (decl-form decls) + (dolist (decl (cdr decl-form)) + (case (car decl) + ((IGNORE IGNORABLE DYNAMIC-EXTENT SPECIAL) + (let (rel oth) + + ...) + ((TYPE FTYPE) ;; FUNCTION? + ...) + ((INLINE NOTINLINE OPTIMIZE DECLARATION) + (push decl other-decls)) + (t + (if (symbolp (car decl)) ;; a type specifier + ... + (push decl other-decls)))))) + (values related-decls other-decls))) +|# + (defun maybe-rewrite-lambda (form) (let* ((lambda-list (cadr form))) (when (memq '&AUX lambda-list) @@ -606,10 +631,64 @@ (setq lambda-list (cadr form))) (multiple-value-bind (body decls doc) (parse-body (cddr form)) - `(lambda ,lambda-list , at decls ,@(when doc `(,doc)) , at body)))) + (let (state let-bindings symbols new-lambda-list + (non-constants 0)) + (do* ((vars lambda-list (cdr vars)) + (var (car vars) (car vars))) + ((endp vars)) + (push (car vars) new-lambda-list) + (let ((replacement (gensym))) + (case var + (&optional (setf state :optional)) + (&key (setf state :key)) + ((&whole &environment &rest &body &allow-other-keys) + ;; do nothing + ) + (t + (when (and (atom var) + (eq state :key)) + (setf var (list var))) + (cond + ((and (atom var) + (neq state :key)) + (setf (car new-lambda-list) replacement) + (push (list var replacement) + let-bindings)) ;; do nothing + (t ;; "(x (some-function))" "((:x q) (some-function))" + ;; or even "(x (some-function) x-supplied-p)" + (destructuring-bind + (name &optional (initform nil initform-supplied-p) + (supplied-p nil supplied-p-supplied-p)) + var + (when (and initform-supplied-p + (not (constantp initform))) + (incf non-constants)) + (let* ((symbol (if (listp name) (second name) name)) + (keyword (if (listp name) (car name) + (intern (symbol-name symbol) + (find-package "KEYWORD")))) + (supplied-p-replacement + (if supplied-p-supplied-p + supplied-p (gensym)))) + (setf (car new-lambda-list) + `(,(if (eq state :key) + (list keyword replacement) replacement) + nil ,supplied-p-replacement)) + (push `(,symbol (if ,supplied-p-replacement + ,replacement ,initform)) + let-bindings) + (push symbol symbols))))))))) + (if (zerop non-constants) + ;; there was no reason to rewrite... + form + `(lambda ,(nreverse new-lambda-list) + ,@(when doc (list doc)) + (let* ,(nreverse let-bindings) + , at decls , at body))))))) (defun precompile-lambda (form) (setq form (maybe-rewrite-lambda form)) +;; (sys::%format t "~S~%" form) (let ((body (cddr form)) (*inline-declarations* *inline-declarations*)) (process-optimization-declarations body) @@ -804,9 +883,14 @@ (when (find-use name (cddr local)) (setf used-p t) (return)) - ;; Scope of defined function names includes &AUX parameters (LABELS.7B). - (let ((aux-vars (cdr (memq '&aux (cadr local))))) - (when (and aux-vars (find-use name aux-vars) + ;; Scope of defined function names includes + ;; &OPTIONAL, &KEY and &AUX parameters + ;; (LABELS.7B, LABELS.7C and LABELS.7D). + (let ((vars (or + (cdr (memq '&optional (cadr local))) + (cdr (memq '&key (cadr local))) + (cdr (memq '&aux (cadr local)))))) + (when (and vars (find-use name vars) (setf used-p t) (return)))))))) (unless used-p From ehuelsmann at common-lisp.net Sun Apr 26 07:12:21 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 26 Apr 2009 03:12:21 -0400 Subject: [armedbear-cvs] r11787 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Apr 26 03:12:21 2009 New Revision: 11787 Log: Remove accidentally committed code. Do some re-indenting elsewhere. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Sun Apr 26 03:12:21 2009 @@ -353,7 +353,6 @@ (declaim (ftype (function (t) t) precompile1)) (defun precompile1 (form) -;; (sys::%format t "~S~%" form) (cond ((symbolp form) (let ((varspec (find-varspec form))) (cond ((and varspec (eq (second varspec) :symbol-macro)) @@ -597,32 +596,14 @@ (setq aux-vars (nreverse aux-vars)) (setq lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) (multiple-value-bind (lambda-decls let-decls) - (rewrite-aux-vars-process-decls decls (lambda-list-names lambda-list) aux-vars) - `(lambda ,lambda-list , at lambda-decls (let* ,lets , at let-decls , at body)))))) - -#| -(defun split-declarations (related-symbols decls) - "Splits IGNORE, IGNORABLE, DYNAMIC-EXTENT, TYPE, FTYPE and -into the declarations related to `related-symbols' and the rest." - ;; IGNORE, IGNORABLE and DYNAMIC-EXTENT have the same format - (let (related-decls other-decls) - (dolist (decl-form decls) - (dolist (decl (cdr decl-form)) - (case (car decl) - ((IGNORE IGNORABLE DYNAMIC-EXTENT SPECIAL) - (let (rel oth) - - ...) - ((TYPE FTYPE) ;; FUNCTION? - ...) - ((INLINE NOTINLINE OPTIMIZE DECLARATION) - (push decl other-decls)) - (t - (if (symbolp (car decl)) ;; a type specifier - ... - (push decl other-decls)))))) - (values related-decls other-decls))) -|# + (rewrite-aux-vars-process-decls decls + (lambda-list-names lambda-list) + aux-vars) + `(lambda ,lambda-list + , at lambda-decls + (let* ,lets + , at let-decls + , at body)))))) (defun maybe-rewrite-lambda (form) (let* ((lambda-list (cadr form))) @@ -688,7 +669,6 @@ (defun precompile-lambda (form) (setq form (maybe-rewrite-lambda form)) -;; (sys::%format t "~S~%" form) (let ((body (cddr form)) (*inline-declarations* *inline-declarations*)) (process-optimization-declarations body) From ehuelsmann at common-lisp.net Mon Apr 27 20:25:00 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 27 Apr 2009 16:25:00 -0400 Subject: [armedbear-cvs] r11788 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Apr 27 16:24:57 2009 New Revision: 11788 Log: Rewriting version 2: cleaner code and rewrite SUPPLIED-P parameters too. 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 Apr 27 16:24:57 2009 @@ -612,60 +612,99 @@ (setq lambda-list (cadr form))) (multiple-value-bind (body decls doc) (parse-body (cddr form)) - (let (state let-bindings symbols new-lambda-list + (let (state let-bindings new-lambda-list (non-constants 0)) (do* ((vars lambda-list (cdr vars)) (var (car vars) (car vars))) ((endp vars)) (push (car vars) new-lambda-list) (let ((replacement (gensym))) + (flet ((parse-compound-argument (arg) + "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, + SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument." + (destructuring-bind + (name &optional (initform nil initform-supplied-p) + (supplied-p nil supplied-p-supplied-p)) + (if (listp arg) arg (list arg)) + (if (listp name) + (values (cadr name) (car name) + initform initform-supplied-p + supplied-p supplied-p-supplied-p) + (values name (make-keyword name) + initform initform-supplied-p + supplied-p supplied-p-supplied-p))))) (case var (&optional (setf state :optional)) (&key (setf state :key)) ((&whole &environment &rest &body &allow-other-keys) - ;; do nothing + ;; do nothing special ) (t - (when (and (atom var) - (eq state :key)) - (setf var (list var))) (cond - ((and (atom var) - (neq state :key)) - (setf (car new-lambda-list) replacement) - (push (list var replacement) - let-bindings)) ;; do nothing - (t ;; "(x (some-function))" "((:x q) (some-function))" - ;; or even "(x (some-function) x-supplied-p)" - (destructuring-bind - (name &optional (initform nil initform-supplied-p) - (supplied-p nil supplied-p-supplied-p)) - var - (when (and initform-supplied-p - (not (constantp initform))) - (incf non-constants)) - (let* ((symbol (if (listp name) (second name) name)) - (keyword (if (listp name) (car name) - (intern (symbol-name symbol) - (find-package "KEYWORD")))) - (supplied-p-replacement - (if supplied-p-supplied-p - supplied-p (gensym)))) + ((atom var) + (setf (car new-lambda-list) + (if (eq state :key) + (list (list (make-keyword var) replacement)) + replacement)) + (push (list var replacement) let-bindings)) + ((constantp (second var)) + ;; so, we must have a consp-type var we're looking at + ;; and it has a constantp initform + (multiple-value-bind + (name keyword initform initform-supplied-p + supplied-p supplied-p-supplied-p) + (parse-compound-argument var) + (let ((var-form (if (eq state :key) + (list keyword replacement) + replacement)) + (supplied-p-replacement (gensym))) (setf (car new-lambda-list) - `(,(if (eq state :key) - (list keyword replacement) replacement) - nil ,supplied-p-replacement)) - (push `(,symbol (if ,supplied-p-replacement - ,replacement ,initform)) - let-bindings) - (push symbol symbols))))))))) + (cond + ((not initform-supplied-p) + (list var-form)) + ((not supplied-p-supplied-p) + (list var-form initform)) + (t + (list var-form initform + supplied-p-replacement)))) + (push (list name replacement) let-bindings) + ;; if there was a 'supplied-p' variable, it might + ;; be used in the declarations. Since those will be + ;; moved below the LET* block, we need to move the + ;; supplied-p parameter too. + (when supplied-p-supplied-p + (push (list supplied-p supplied-p-replacement) + let-bindings))))) + (t + (incf non-constants) + ;; this is either a keyword or an optional argument + ;; with a non-constantp initform + (multiple-value-bind + (name keyword initform initform-supplied-p + supplied-p supplied-p-supplied-p) + (parse-compound-argument var) + (declare (ignore initform-supplied-p)) + (let ((var-form (if (eq state :key) + (list keyword replacement) + replacement)) + (supplied-p-replacement (gensym))) + (setf (car new-lambda-list) + (list var-form nil supplied-p-replacement)) + (push (list name `(if ,supplied-p-replacement + ,replacement ,initform)) + let-bindings) + (when supplied-p-supplied-p + (push (list supplied-p supplied-p-replacement) + let-bindings))))))))))) (if (zerop non-constants) ;; there was no reason to rewrite... form - `(lambda ,(nreverse new-lambda-list) - ,@(when doc (list doc)) - (let* ,(nreverse let-bindings) - , at decls , at body))))))) + (let ((rv + `(lambda ,(nreverse new-lambda-list) + ,@(when doc (list doc)) + (let* ,(nreverse let-bindings) + , at decls , at body)))) + rv)))))) (defun precompile-lambda (form) (setq form (maybe-rewrite-lambda form)) @@ -1189,8 +1228,11 @@ (multiple-value-bind (body decls doc) (parse-body body) (let* ((block-name (fdefinition-block-name name)) - (lambda-expression `(named-lambda ,name ,lambda-list , at decls ,@(when doc `(,doc)) - (block ,block-name , at body)))) + (lambda-expression + `(named-lambda ,name ,lambda-list + , at decls + ,@(when doc `(,doc)) + (block ,block-name , at body)))) (cond ((and (boundp 'jvm::*file-compilation*) ;; when JVM.lisp isn't loaded yet, this variable isn't bound ;; meaning that we're not trying to compile to a file: @@ -1206,4 +1248,4 @@ `(progn (%defun ',name ,lambda-expression) ,@(when doc - `((%set-documentation ',name 'function ,doc))))))))) + `((%set-documentation ',name 'function ,doc))))))))) From vvoutilainen at common-lisp.net Mon Apr 27 21:10:25 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Mon, 27 Apr 2009 17:10:25 -0400 Subject: [armedbear-cvs] r11789 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Mon Apr 27 17:10:24 2009 New Revision: 11789 Log: Tiny cleanup to invocations of compile-xep. 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 Mon Apr 27 17:10:24 2009 @@ -858,6 +858,13 @@ (initialize-p1-handlers) +(defun invoke-compile-xep (xep-lambda-expression compiland) + (let ((xep-compiland + (make-compiland :lambda-expression + (precompile-form xep-lambda-expression t) + :class-file (compiland-class-file compiland)))) + (compile-xep xep-compiland))) + (defun p1-compiland (compiland) ;; (format t "p1-compiland name = ~S~%" (compiland-name compiland)) (let ((form (compiland-lambda-expression compiland))) @@ -901,19 +908,13 @@ (,supplied-p-var nil)) (%call-internal , at all-args))))) (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression) - (let ((xep-compiland - (make-compiland :lambda-expression (precompile-form xep-lambda-expression t) - :class-file (compiland-class-file compiland)))) - (compile-xep xep-compiland))) + (invoke-compile-xep xep-lambda-expression compiland)) (let ((xep-lambda-expression `(lambda ,(append required-args (list name)) (let* ((,supplied-p-var t)) (%call-internal , at all-args))))) (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression) - (let ((xep-compiland - (make-compiland :lambda-expression (precompile-form xep-lambda-expression t) - :class-file (compiland-class-file compiland)))) - (compile-xep xep-compiland))) + (invoke-compile-xep xep-lambda-expression compiland)) (setf lambda-list all-args) (setf (compiland-kind compiland) :internal)) (t @@ -922,10 +923,7 @@ (let* ((,name ,initform)) (,(compiland-name compiland) , at all-args))))) (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression) - (let ((xep-compiland - (make-compiland :lambda-expression (precompile-form xep-lambda-expression t) - :class-file (compiland-class-file compiland)))) - (compile-xep xep-compiland))) + (invoke-compile-xep xep-lambda-expression compiland)) (setf lambda-list all-args)))))))))) (let* ((closure (make-closure `(lambda ,lambda-list nil) nil)) From ehuelsmann at common-lisp.net Mon Apr 27 21:27:52 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 27 Apr 2009 17:27:52 -0400 Subject: [armedbear-cvs] r11790 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Apr 27 17:27:51 2009 New Revision: 11790 Log: Remove a NIL block which doesn't seem to matter. Since we add named blocks all over the place, surely adding an implicit NIL block isn't a good thing. 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 Mon Apr 27 17:27:51 2009 @@ -510,9 +510,8 @@ (multiple-value-bind (body decls) (parse-body body) (setf (compiland-lambda-expression compiland) - (if named-lambda-p - `(lambda ,lambda-list , at decls (block nil , at body)) - `(lambda ,lambda-list , at decls , at body))) + ;; if there still was a doc-string present, remove it + `(lambda ,lambda-list , at decls , at body)) (let ((*visible-variables* *visible-variables*) (*current-compiland* compiland)) (p1-compiland compiland))) From astalla at common-lisp.net Tue Apr 28 18:43:58 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 28 Apr 2009 14:43:58 -0400 Subject: [armedbear-cvs] r11791 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Apr 28 14:43:56 2009 New Revision: 11791 Log: Added autoload for system::%float-bits. Its absence prevented Slime from loading in certain situations, when launched from Java using Interpreter.eval(). 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 Tue Apr 28 14:43:56 2009 @@ -606,6 +606,7 @@ autoload(PACKAGE_SYS, "cache-slot-location", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "canonicalize-logical-host", "LogicalPathname", true); autoload(PACKAGE_SYS, "class-direct-slots", "SlotClass"); + autoload(PACKAGE_SYS, "%float-bits", "FloatFunctions"); autoload(PACKAGE_SYS, "coerce-to-double-float", "FloatFunctions"); autoload(PACKAGE_SYS, "coerce-to-single-float", "FloatFunctions"); autoload(PACKAGE_SYS, "compute-class-direct-slots", "SlotClass", true); From vvoutilainen at common-lisp.net Tue Apr 28 19:38:42 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 28 Apr 2009 15:38:42 -0400 Subject: [armedbear-cvs] r11792 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Tue Apr 28 15:38:42 2009 New Revision: 11792 Log: Little combination fix for pool-long and pool-double. 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 Apr 28 15:38:42 2009 @@ -134,14 +134,8 @@ (declare (optimize speed)) (pool-get (list 4 (%float-bits n)))) -(defknown pool-long (integer) (integer 1 65535)) -(defun pool-long (n) - (declare (optimize speed)) - (declare (type java-long n)) - (let* ((entry (list 5 - (logand (ash n -32) #xffffffff) - (logand n #xffffffff))) - (ht *pool-entries*) +(defun pool-long/double (n entry) + (let* ((ht *pool-entries*) (index (gethash1 entry ht))) (declare (type hash-table ht)) (unless index @@ -157,28 +151,23 @@ (setf *pool-count* (+ index 2))) index)) +(defknown pool-long (integer) (integer 1 65535)) +(defun pool-long (n) + (declare (optimize speed)) + (declare (type java-long n)) + (let* ((entry (list 5 + (logand (ash n -32) #xffffffff) + (logand n #xffffffff)))) + (pool-long/double n entry))) + (defknown pool-double (double-float) (integer 1 65535)) (defun pool-double (n) (declare (optimize speed)) (let* ((n (%float-bits n)) (entry (list 6 (logand (ash n -32) #xffffffff) - (logand n #xffffffff))) - (ht *pool-entries*) - (index (gethash1 entry ht))) - (declare (type hash-table ht)) - (unless index - (setf index *pool-count*) - (push entry *pool*) - (setf (gethash entry ht) index) - ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte - ;; constants take up two entries in the constant_pool table of the class - ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the - ;; item in the constant_pool table at index n, then the next usable item in - ;; the pool is located at index n+2. The constant_pool index n+1 must be - ;; valid but is considered unusable." So: - (setf *pool-count* (+ index 2))) - index)) + (logand n #xffffffff)))) + (pool-long/double n entry))) (defknown u2 (fixnum) cons) (defun u2 (n) From vvoutilainen at common-lisp.net Tue Apr 28 20:24:11 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 28 Apr 2009 16:24:11 -0400 Subject: [armedbear-cvs] r11793 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Tue Apr 28 16:24:10 2009 New Revision: 11793 Log: Combine load/store resolvers. 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 Apr 28 16:24:10 2009 @@ -1153,77 +1153,40 @@ (setf (gethash op +resolvers+) (symbol-function ',name))) `(setf (gethash ,opcodes +resolvers+) (symbol-function ',name))))))) -;; aload -(define-resolver 25 (instruction) +(defun load/store-resolver (instruction inst-index inst-index2 error-text) (let* ((args (instruction-args instruction)) (index (car args))) (declare (type (unsigned-byte 16) index)) (cond ((<= 0 index 3) - (inst (+ index 42))) + (inst (+ index inst-index))) ((<= 0 index 255) - (inst 25 index)) + (inst inst-index2 index)) (t - (error "ALOAD unsupported case"))))) + (error error-text))))) + +;; aload +(define-resolver 25 (instruction) + (load/store-resolver instruction 42 25 "ALOAD unsupported case")) ;; astore (define-resolver 58 (instruction) - (let* ((args (instruction-args instruction)) - (index (car args))) - (declare (type (unsigned-byte 16) index)) - (cond ((<= 0 index 3) - (inst (+ index 75))) - ((<= 0 index 255) - (inst 58 index)) - (t - (error "ASTORE unsupported case"))))) + (load/store-resolver instruction 75 58 "ASTORE unsupported case")) ;; iload (define-resolver 21 (instruction) - (let* ((args (instruction-args instruction)) - (index (car args))) - (declare (type (unsigned-byte 16) index)) - (cond ((<= 0 index 3) - (inst (+ index 26))) - ((<= 0 index 255) - (inst 21 index)) - (t - (error "ILOAD unsupported case"))))) + (load/store-resolver instruction 26 21 "ILOAD unsupported case")) ;; istore (define-resolver 54 (instruction) - (let* ((args (instruction-args instruction)) - (index (car args))) - (declare (type (unsigned-byte 16) index)) - (cond ((<= 0 index 3) - (inst (+ index 59))) - ((<= 0 index 255) - (inst 54 index)) - (t - (error "ASTORE unsupported case"))))) + (load/store-resolver instruction 59 54 "ISTORE unsupported case")) ;; lload (define-resolver 22 (instruction) - (let* ((args (instruction-args instruction)) - (index (car args))) - (declare (type (unsigned-byte 16) index)) - (cond ((<= 0 index 3) - (inst (+ index 30))) - ((<= 0 index 255) - (inst 22 index)) - (t - (error "LLOAD unsupported case"))))) + (load/store-resolver instruction 30 22 "LLOAD unsupported case")) ;; lstore (define-resolver 55 (instruction) - (let* ((args (instruction-args instruction)) - (index (car args))) - (declare (type (unsigned-byte 16) index)) - (cond ((<= 0 index 3) - (inst (+ index 63))) - ((<= 0 index 255) - (inst 55 index)) - (t - (error "ASTORE unsupported case"))))) + (load/store-resolver instruction 63 55 "LSTORE unsupported case")) ;; getstatic, putstatic (define-resolver (178 179) (instruction) From ehuelsmann at common-lisp.net Tue Apr 28 21:09:30 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 28 Apr 2009 17:09:30 -0400 Subject: [armedbear-cvs] r11794 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Apr 28 17:09:29 2009 New Revision: 11794 Log: Precompile lambda-list initforms. 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 Tue Apr 28 17:09:29 2009 @@ -706,20 +706,36 @@ , at decls , at body)))) rv)))))) +(defun precompile-lambda-list (form) + (let (new) + (dolist (arg form (nreverse new)) + (if (or (atom arg) (> 2 (length arg))) + (push arg new) + ;; must be a cons of more than 1 cell + (let ((new-arg (copy-list arg))) + (setf (second new-arg) + (precompile1 (second arg))) + (push new-arg new)))))) + (defun precompile-lambda (form) (setq form (maybe-rewrite-lambda form)) (let ((body (cddr form)) + (precompiled-lambda-list + (precompile-lambda-list (cadr form))) (*inline-declarations* *inline-declarations*)) (process-optimization-declarations body) - (list* 'LAMBDA (cadr form) (mapcar #'precompile1 body)))) + (list* 'LAMBDA precompiled-lambda-list + (mapcar #'precompile1 body)))) (defun precompile-named-lambda (form) (let ((lambda-form (list* 'LAMBDA (caddr form) (cdddr form)))) (setf lambda-form (maybe-rewrite-lambda lambda-form)) (let ((body (cddr lambda-form)) + (precompiled-lambda-list + (precompile-lambda-list (cadr lambda-form))) (*inline-declarations* *inline-declarations*)) (process-optimization-declarations body) - (list* 'NAMED-LAMBDA (cadr form) (cadr lambda-form) + (list* 'NAMED-LAMBDA (cadr form) precompiled-lambda-list (mapcar #'precompile1 body))))) (defun precompile-defun (form) From mevenson at common-lisp.net Wed Apr 29 10:16:59 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 29 Apr 2009 06:16:59 -0400 Subject: [armedbear-cvs] r11795 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Apr 29 06:16:57 2009 New Revision: 11795 Log: Ant-based build works again, fixing error introduced in r11792 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 Wed Apr 29 06:16:57 2009 @@ -134,7 +134,7 @@ (declare (optimize speed)) (pool-get (list 4 (%float-bits n)))) -(defun pool-long/double (n entry) +(defun pool-long/double (entry) (let* ((ht *pool-entries*) (index (gethash1 entry ht))) (declare (type hash-table ht)) @@ -158,7 +158,7 @@ (let* ((entry (list 5 (logand (ash n -32) #xffffffff) (logand n #xffffffff)))) - (pool-long/double n entry))) + (pool-long/double entry))) (defknown pool-double (double-float) (integer 1 65535)) (defun pool-double (n) @@ -167,7 +167,7 @@ (entry (list 6 (logand (ash n -32) #xffffffff) (logand n #xffffffff)))) - (pool-long/double n entry))) + (pool-long/double entry))) (defknown u2 (fixnum) cons) (defun u2 (n) From ehuelsmann at common-lisp.net Wed Apr 29 17:27:03 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Apr 2009 13:27:03 -0400 Subject: [armedbear-cvs] r11796 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 29 13:27:00 2009 New Revision: 11796 Log: Move &AUX vars argument list rewriting from the preprocessor to the compiler: the interpreter doesn't need it. In the process, replace the "simple" rewriting in the compiler with the more advanced approach (taking declarations into account) available after the move. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.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 Wed Apr 29 13:27:00 2009 @@ -416,8 +416,63 @@ (push variable *visible-variables*)))) , at body2))) +(defun rewrite-aux-vars-process-decls (forms arg-vars aux-vars) + (declare (ignore aux-vars)) + (let ((lambda-decls nil) + (let-decls nil)) + (dolist (form forms) + (unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen + (return)) + (dolist (decl (cdr form)) + (case (car decl) + ((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE) + (push (list 'DECLARE decl) lambda-decls)) + (SPECIAL + (dolist (name (cdr decl)) + (if (memq name arg-vars) + (push (list 'DECLARE (list 'SPECIAL name)) lambda-decls) + (push (list 'DECLARE (list 'SPECIAL name)) let-decls)))) + (TYPE + (dolist (name (cddr decl)) + (if (memq name arg-vars) + (push (list 'DECLARE (list 'TYPE (cadr decl) name)) lambda-decls) + (push (list 'DECLARE (list 'TYPE (cadr decl) name)) let-decls)))) + (t + (dolist (name (cdr decl)) + (if (memq name arg-vars) + (push (list 'DECLARE (list (car decl) name)) lambda-decls) + (push (list 'DECLARE (list (car decl) name)) let-decls))))))) + (setq lambda-decls (nreverse lambda-decls)) + (setq let-decls (nreverse let-decls)) + (values lambda-decls let-decls))) + +(defun maybe-rewrite-aux-vars (form) + (let* ((lambda-list (cadr form)) + (lets (cdr (memq '&AUX lambda-list))) + aux-vars) + (unless lets + ;; no rewriting required + (return-from maybe-rewrite-aux-vars form)) + (multiple-value-bind (body decls) + (parse-body (cddr form)) + (dolist (form lets) + (cond ((consp form) + (push (%car form) aux-vars)) + (t + (push form aux-vars)))) + (setq lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) + (multiple-value-bind (lambda-decls let-decls) + (rewrite-aux-vars-process-decls decls + (lambda-list-names lambda-list) + (nreverse aux-vars)) + `(lambda ,lambda-list + , at lambda-decls + (let* ,lets + , at let-decls + , at body)))))) + (defun p1-flet (form) - (with-local-functions-for-flet/labels + (with-local-functions-for-flet/labels form local-functions 'FLET lambda-list name body ((let ((local-function (make-local-function :name name :compiland compiland))) @@ -443,7 +498,7 @@ (defun p1-labels (form) - (with-local-functions-for-flet/labels + (with-local-functions-for-flet/labels form local-functions 'LABELS lambda-list name body ((let* ((variable (make-variable :name (gensym))) (local-function (make-local-function :name name @@ -511,7 +566,8 @@ (parse-body body) (setf (compiland-lambda-expression compiland) ;; if there still was a doc-string present, remove it - `(lambda ,lambda-list , at decls , at body)) + (maybe-rewrite-aux-vars + `(lambda ,lambda-list , at decls , at body))) (let ((*visible-variables* *visible-variables*) (*current-compiland* compiland)) (p1-compiland compiland))) @@ -527,9 +583,7 @@ form)))) (defun p1-lambda (form) - (let* ((lambda-list (cadr form)) - (body (cddr form)) - (auxvars (memq '&AUX lambda-list))) + (let* ((lambda-list (cadr form))) (when (or (memq '&optional lambda-list) (memq '&key lambda-list)) (let ((state nil)) @@ -541,10 +595,8 @@ (not (constantp (second arg)))) (compiler-unsupported "P1-LAMBDA: can't handle optional argument with non-constant initform."))))))) - (when auxvars - (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) - (setf body (list (append (list 'LET* (cdr auxvars)) body)))) - (p1-function (list 'FUNCTION (list* 'LAMBDA lambda-list body))))) + (p1-function (list 'FUNCTION + (maybe-rewrite-aux-vars form))))) (defun p1-eval-when (form) (list* (car form) (cadr form) (mapcar #'p1 (cddr form)))) @@ -868,14 +920,11 @@ ;; (format t "p1-compiland name = ~S~%" (compiland-name compiland)) (let ((form (compiland-lambda-expression compiland))) (aver (eq (car form) 'LAMBDA)) + (setf form (maybe-rewrite-aux-vars form)) (process-optimization-declarations (cddr form)) (let* ((lambda-list (cadr form)) - (body (cddr form)) - (auxvars (memq '&AUX lambda-list))) - (when auxvars - (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) - (setf body (list (append (list 'LET* (cdr auxvars)) body)))) + (body (cddr form))) (when (and (null (compiland-parent compiland)) ;; FIXME support SETF functions! Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed Apr 29 13:27:00 2009 @@ -551,65 +551,8 @@ ;; Delegate to PRECOMPILE-PSETF so symbol macros are handled correctly. (precompile-psetf form)) -(defun rewrite-aux-vars-process-decls (forms arg-vars aux-vars) - (declare (ignore aux-vars)) - (let ((lambda-decls nil) - (let-decls nil)) - (dolist (form forms) - (unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen - (return)) - (dolist (decl (cdr form)) - (case (car decl) - ((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE) - (push (list 'DECLARE decl) lambda-decls)) - (SPECIAL - (dolist (name (cdr decl)) - (if (memq name arg-vars) - (push (list 'DECLARE (list 'SPECIAL name)) lambda-decls) - (push (list 'DECLARE (list 'SPECIAL name)) let-decls)))) - (TYPE - (dolist (name (cddr decl)) - (if (memq name arg-vars) - (push (list 'DECLARE (list 'TYPE (cadr decl) name)) lambda-decls) - (push (list 'DECLARE (list 'TYPE (cadr decl) name)) let-decls)))) - (t - (dolist (name (cdr decl)) - (if (memq name arg-vars) - (push (list 'DECLARE (list (car decl) name)) lambda-decls) - (push (list 'DECLARE (list (car decl) name)) let-decls))))))) - (setq lambda-decls (nreverse lambda-decls)) - (setq let-decls (nreverse let-decls)) - (values lambda-decls let-decls))) - -(defun rewrite-aux-vars (form) - (multiple-value-bind (body decls doc) - (parse-body (cddr form)) - (declare (ignore doc)) ; FIXME - (let* ((lambda-list (cadr form)) - (lets (cdr (memq '&AUX lambda-list))) - aux-vars) - (dolist (form lets) - (cond ((consp form) - (push (%car form) aux-vars)) - (t - (push form aux-vars)))) - (setq aux-vars (nreverse aux-vars)) - (setq lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) - (multiple-value-bind (lambda-decls let-decls) - (rewrite-aux-vars-process-decls decls - (lambda-list-names lambda-list) - aux-vars) - `(lambda ,lambda-list - , at lambda-decls - (let* ,lets - , at let-decls - , at body)))))) - (defun maybe-rewrite-lambda (form) (let* ((lambda-list (cadr form))) - (when (memq '&AUX lambda-list) - (setq form (rewrite-aux-vars form)) - (setq lambda-list (cadr form))) (multiple-value-bind (body decls doc) (parse-body (cddr form)) (let (state let-bindings new-lambda-list From ehuelsmann at common-lisp.net Wed Apr 29 19:11:46 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Apr 2009 15:11:46 -0400 Subject: [armedbear-cvs] r11797 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 29 15:11:44 2009 New Revision: 11797 Log: Fix the build. Removal of &aux variables rewriting broke it. 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 Wed Apr 29 15:11:44 2009 @@ -553,101 +553,105 @@ (defun maybe-rewrite-lambda (form) (let* ((lambda-list (cadr form))) - (multiple-value-bind (body decls doc) - (parse-body (cddr form)) - (let (state let-bindings new-lambda-list - (non-constants 0)) - (do* ((vars lambda-list (cdr vars)) - (var (car vars) (car vars))) - ((endp vars)) - (push (car vars) new-lambda-list) - (let ((replacement (gensym))) - (flet ((parse-compound-argument (arg) - "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, + (if (not (or (memq '&optional lambda-list) + (memq '&key lambda-list))) + ;; no need to rewrite: no arguments with possible initforms anyway + form + (multiple-value-bind (body decls doc) + (parse-body (cddr form)) + (let (state let-bindings new-lambda-list + (non-constants 0)) + (do* ((vars lambda-list (cdr vars)) + (var (car vars) (car vars))) + ((or (endp vars) (eq '&aux (car vars)))) + (push (car vars) new-lambda-list) + (let ((replacement (gensym))) + (flet ((parse-compound-argument (arg) + "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument." - (destructuring-bind - (name &optional (initform nil initform-supplied-p) - (supplied-p nil supplied-p-supplied-p)) - (if (listp arg) arg (list arg)) - (if (listp name) - (values (cadr name) (car name) - initform initform-supplied-p - supplied-p supplied-p-supplied-p) - (values name (make-keyword name) - initform initform-supplied-p - supplied-p supplied-p-supplied-p))))) - (case var - (&optional (setf state :optional)) - (&key (setf state :key)) - ((&whole &environment &rest &body &allow-other-keys) - ;; do nothing special - ) - (t - (cond - ((atom var) - (setf (car new-lambda-list) - (if (eq state :key) - (list (list (make-keyword var) replacement)) - replacement)) - (push (list var replacement) let-bindings)) - ((constantp (second var)) - ;; so, we must have a consp-type var we're looking at - ;; and it has a constantp initform - (multiple-value-bind - (name keyword initform initform-supplied-p - supplied-p supplied-p-supplied-p) - (parse-compound-argument var) - (let ((var-form (if (eq state :key) - (list keyword replacement) - replacement)) - (supplied-p-replacement (gensym))) + (destructuring-bind + (name &optional (initform nil initform-supplied-p) + (supplied-p nil supplied-p-supplied-p)) + (if (listp arg) arg (list arg)) + (if (listp name) + (values (cadr name) (car name) + initform initform-supplied-p + supplied-p supplied-p-supplied-p) + (values name (make-keyword name) + initform initform-supplied-p + supplied-p supplied-p-supplied-p))))) + (case var + (&optional (setf state :optional)) + (&key (setf state :key)) + ((&whole &environment &rest &body &allow-other-keys) + ;; do nothing special + ) + (t + (cond + ((atom var) (setf (car new-lambda-list) - (cond - ((not initform-supplied-p) - (list var-form)) - ((not supplied-p-supplied-p) - (list var-form initform)) - (t - (list var-form initform - supplied-p-replacement)))) - (push (list name replacement) let-bindings) - ;; if there was a 'supplied-p' variable, it might - ;; be used in the declarations. Since those will be - ;; moved below the LET* block, we need to move the - ;; supplied-p parameter too. - (when supplied-p-supplied-p - (push (list supplied-p supplied-p-replacement) - let-bindings))))) - (t - (incf non-constants) - ;; this is either a keyword or an optional argument - ;; with a non-constantp initform - (multiple-value-bind - (name keyword initform initform-supplied-p - supplied-p supplied-p-supplied-p) - (parse-compound-argument var) - (declare (ignore initform-supplied-p)) - (let ((var-form (if (eq state :key) - (list keyword replacement) - replacement)) - (supplied-p-replacement (gensym))) - (setf (car new-lambda-list) - (list var-form nil supplied-p-replacement)) - (push (list name `(if ,supplied-p-replacement - ,replacement ,initform)) - let-bindings) - (when supplied-p-supplied-p - (push (list supplied-p supplied-p-replacement) - let-bindings))))))))))) - (if (zerop non-constants) - ;; there was no reason to rewrite... - form - (let ((rv - `(lambda ,(nreverse new-lambda-list) - ,@(when doc (list doc)) - (let* ,(nreverse let-bindings) - , at decls , at body)))) - rv)))))) + (if (eq state :key) + (list (list (make-keyword var) replacement)) + replacement)) + (push (list var replacement) let-bindings)) + ((constantp (second var)) + ;; so, we must have a consp-type var we're looking at + ;; and it has a constantp initform + (multiple-value-bind + (name keyword initform initform-supplied-p + supplied-p supplied-p-supplied-p) + (parse-compound-argument var) + (let ((var-form (if (eq state :key) + (list keyword replacement) + replacement)) + (supplied-p-replacement (gensym))) + (setf (car new-lambda-list) + (cond + ((not initform-supplied-p) + (list var-form)) + ((not supplied-p-supplied-p) + (list var-form initform)) + (t + (list var-form initform + supplied-p-replacement)))) + (push (list name replacement) let-bindings) + ;; if there was a 'supplied-p' variable, it might + ;; be used in the declarations. Since those will be + ;; moved below the LET* block, we need to move the + ;; supplied-p parameter too. + (when supplied-p-supplied-p + (push (list supplied-p supplied-p-replacement) + let-bindings))))) + (t + (incf non-constants) + ;; this is either a keyword or an optional argument + ;; with a non-constantp initform + (multiple-value-bind + (name keyword initform initform-supplied-p + supplied-p supplied-p-supplied-p) + (parse-compound-argument var) + (declare (ignore initform-supplied-p)) + (let ((var-form (if (eq state :key) + (list keyword replacement) + replacement)) + (supplied-p-replacement (gensym))) + (setf (car new-lambda-list) + (list var-form nil supplied-p-replacement)) + (push (list name `(if ,supplied-p-replacement + ,replacement ,initform)) + let-bindings) + (when supplied-p-supplied-p + (push (list supplied-p supplied-p-replacement) + let-bindings))))))))))) + (if (zerop non-constants) + ;; there was no reason to rewrite... + form + (let ((rv + `(lambda ,(nreverse new-lambda-list) + ,@(when doc (list doc)) + (let* ,(nreverse let-bindings) + , at decls , at body)))) + rv))))))) (defun precompile-lambda-list (form) (let (new) From ehuelsmann at common-lisp.net Wed Apr 29 19:49:20 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Apr 2009 15:49:20 -0400 Subject: [armedbear-cvs] r11798 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 29 15:49:19 2009 New Revision: 11798 Log: Remove the use of XEPs (eXternal Entry Points) which were optimizing for the 1-optional-argument special case by calling an internal entry point if that argument was provided and the XEP otherwise. This is too much code to justify this case. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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 Wed Apr 29 15:49:19 2009 @@ -909,13 +909,6 @@ (initialize-p1-handlers) -(defun invoke-compile-xep (xep-lambda-expression compiland) - (let ((xep-compiland - (make-compiland :lambda-expression - (precompile-form xep-lambda-expression t) - :class-file (compiland-class-file compiland)))) - (compile-xep xep-compiland))) - (defun p1-compiland (compiland) ;; (format t "p1-compiland name = ~S~%" (compiland-name compiland)) (let ((form (compiland-lambda-expression compiland))) @@ -926,54 +919,6 @@ (let* ((lambda-list (cadr form)) (body (cddr form))) - (when (and (null (compiland-parent compiland)) - ;; FIXME support SETF functions! - (symbolp (compiland-name compiland))) - (when (memq '&OPTIONAL lambda-list) - (unless (or (memq '&KEY lambda-list) (memq '&REST lambda-list)) - (let ((required-args (subseq lambda-list 0 (position '&OPTIONAL lambda-list))) - (optional-args (cdr (memq '&OPTIONAL lambda-list)))) - (dformat t "optional-args = ~S~%" optional-args) - (when (= (length optional-args) 1) - (let* ((optional-arg (car optional-args)) - (name (if (consp optional-arg) (%car optional-arg) optional-arg)) - (initform (if (consp optional-arg) (cadr optional-arg) nil)) - (supplied-p-var (and (consp optional-arg) - (= (length optional-arg) 3) - (third optional-arg))) - (all-args - (append required-args (list name) - (when supplied-p-var (list supplied-p-var))))) - (when (<= (length all-args) call-registers-limit) - (dformat t "optional-arg = ~S~%" optional-arg) - (dformat t "supplied-p-var = ~S~%" supplied-p-var) - (dformat t "required-args = ~S~%" required-args) - (dformat t "all-args = ~S~%" all-args) - (cond (supplied-p-var - (let ((xep-lambda-expression - `(lambda ,required-args - (let* ((,name ,initform) - (,supplied-p-var nil)) - (%call-internal , at all-args))))) - (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression) - (invoke-compile-xep xep-lambda-expression compiland)) - (let ((xep-lambda-expression - `(lambda ,(append required-args (list name)) - (let* ((,supplied-p-var t)) - (%call-internal , at all-args))))) - (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression) - (invoke-compile-xep xep-lambda-expression compiland)) - (setf lambda-list all-args) - (setf (compiland-kind compiland) :internal)) - (t - (let ((xep-lambda-expression - `(lambda ,required-args - (let* ((,name ,initform)) - (,(compiland-name compiland) , at all-args))))) - (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression) - (invoke-compile-xep xep-lambda-expression compiland)) - (setf lambda-list all-args)))))))))) - (let* ((closure (make-closure `(lambda ,lambda-list nil) nil)) (syms (sys::varlist closure)) (vars 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 Wed Apr 29 15:49:19 2009 @@ -8095,55 +8095,6 @@ ;; attributes count (write-u2 0 stream)))))) -(defun compile-xep (xep) - (declare (type compiland xep)) - (let ((*all-variables* ()) - (*closure-variables* ()) - (*current-compiland* xep) - (*speed* 3) - (*safety* 0) - (*debug* 0)) - - (aver (not (null (compiland-class-file xep)))) - - ;; Pass 1. - (p1-compiland xep) -;; (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) - (setf *closure-variables* - (remove-if-not #'variable-used-non-locally-p *all-variables*)) - (setf *closure-variables* - (remove-if #'variable-special-p *closure-variables*)) -;; (dformat t "*closure-variables* = ~S~%" (mapcar #'variable-name *closure-variables*)) - - (when *closure-variables* - (let ((i 0)) - (dolist (var (reverse *closure-variables*)) - (setf (variable-closure-index var) i) - (dformat t "var = ~S closure index = ~S~%" (variable-name var) - (variable-closure-index var)) - (incf i)))) - - ;; Pass 2. - (with-class-file (compiland-class-file xep) - (p2-compiland xep)))) - - -(defun p2-%call-internal (form target representation) - (dformat t "p2-%call-internal~%") - (aload 0) ; this - (let ((args (cdr form)) - (must-clear-values nil)) - (dformat t "args = ~S~%" args) - (dolist (arg args) - (compile-form arg 'stack nil) - (unless must-clear-values - (unless (single-valued-p arg) - (setf must-clear-values t)))) - (let ((arg-types (lisp-object-arg-types (length args))) - (return-type +lisp-object+)) - (emit-invokevirtual *this-class* "_execute" arg-types return-type)) - (emit-move-from-stack target representation))) - (defknown p2-compiland-process-type-declarations (list) t) (defun p2-compiland-process-type-declarations (body) (flet ((process-declaration (name type) @@ -8764,7 +8715,6 @@ multiple-value-prog1 nth progn)) - (install-p2-handler '%call-internal 'p2-%call-internal) (install-p2-handler '%ldb 'p2-%ldb) (install-p2-handler '%make-structure 'p2-%make-structure) (install-p2-handler '* 'p2-times) From ehuelsmann at common-lisp.net Wed Apr 29 20:50:08 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Apr 2009 16:50:08 -0400 Subject: [armedbear-cvs] r11799 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 29 16:50:07 2009 New Revision: 11799 Log: Check LET/LET* and &AUX bindings validity. Also fixes an incorrectly placed paren in clos.lisp found as a result. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.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 Apr 29 16:50:07 2009 @@ -1737,8 +1737,8 @@ (defun add-reader-method (class function-name slot-name) (let* ((lambda-expression (if (eq (class-of class) (find-class 'standard-class)) - `(lambda (object) (std-slot-value object ',slot-name))) - `(lambda (object) (slot-value object ',slot-name))) + `(lambda (object) (std-slot-value object ',slot-name)) + `(lambda (object) (slot-value object ',slot-name)))) (method-function (compute-method-function lambda-expression)) (fast-function (compute-method-fast-function lambda-expression))) (let ((method-lambda-list '(object)) Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed Apr 29 16:50:07 2009 @@ -654,12 +654,23 @@ rv))))))) (defun precompile-lambda-list (form) - (let (new) + (let (new aux-tail) (dolist (arg form (nreverse new)) (if (or (atom arg) (> 2 (length arg))) - (push arg new) + (progn + (when (eq arg '&aux) + (setf aux-tail t)) + (push arg new)) ;; must be a cons of more than 1 cell (let ((new-arg (copy-list arg))) + (unless (<= 1 (length arg) (if aux-tail 2 3)) + ;; the aux-vars have a maximum length of 2 conses + ;; optional and key vars may have 3 + (error 'program-error + :format-control + "The ~A binding specification ~S is invalid." + :format-arguments (list (if aux-tail "&AUX" + "&OPTIONAL/&KEY") arg))) (setf (second new-arg) (precompile1 (second arg))) (push new-arg new)))))) @@ -756,10 +767,11 @@ (let ((result nil)) (dolist (var vars) (cond ((consp var) -;; (when (> (length var) 2) -;; (error 'program-error -;; :format-control "The LET/LET* binding specification ~S is invalid." -;; :format-arguments (list var))) + (unless (<= 1 (length var) 2) + (error 'program-error + :format-control + "The LET/LET* binding specification ~S is invalid." + :format-arguments (list var))) (let ((v (%car var)) (expr (cadr var))) (unless (symbolp v) From ehuelsmann at common-lisp.net Wed Apr 29 20:55:07 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Apr 2009 16:55:07 -0400 Subject: [armedbear-cvs] r11800 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 29 16:55:07 2009 New Revision: 11800 Log: Rewrite aux vars in case of FLET and LABELS too. 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 Wed Apr 29 16:55:07 2009 @@ -479,7 +479,8 @@ (multiple-value-bind (body decls) (parse-body body) (let* ((block-name (fdefinition-block-name name)) (lambda-expression - `(lambda ,lambda-list , at decls (block ,block-name , at body))) + (maybe-rewrite-aux-vars + `(lambda ,lambda-list , at decls (block ,block-name , at body)))) (*visible-variables* *visible-variables*) (*local-functions* *local-functions*) (*current-compiland* compiland)) @@ -506,7 +507,8 @@ :variable variable))) (multiple-value-bind (body decls) (parse-body body) (setf (compiland-lambda-expression compiland) - `(lambda ,lambda-list , at decls (block ,name , at body)))) + (maybe-rewrite-aux-vars + `(lambda ,lambda-list , at decls (block ,name , at body))))) (push variable *all-variables*) (push local-function local-functions))) ((dolist (local-function local-functions) From ehuelsmann at common-lisp.net Wed Apr 29 21:45:25 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Apr 2009 17:45:25 -0400 Subject: [armedbear-cvs] r11801 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 29 17:45:25 2009 New Revision: 11801 Log: Compensate for the fact that we're no longer rewriting &aux vars before entering maybe-rewrite-lambda. 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 Wed Apr 29 17:45:25 2009 @@ -563,7 +563,9 @@ (non-constants 0)) (do* ((vars lambda-list (cdr vars)) (var (car vars) (car vars))) - ((or (endp vars) (eq '&aux (car vars)))) + ((or (endp vars) (eq '&aux (car vars))) + (setf new-lambda-list + (append (reverse vars) new-lambda-list))) (push (car vars) new-lambda-list) (let ((replacement (gensym))) (flet ((parse-compound-argument (arg) From ehuelsmann at common-lisp.net Wed Apr 29 21:46:30 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Apr 2009 17:46:30 -0400 Subject: [armedbear-cvs] r11802 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 29 17:46:29 2009 New Revision: 11802 Log: Rename maybe-rewrite-aux-vars -> rewrite-aux-vars. 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 Wed Apr 29 17:46:29 2009 @@ -416,56 +416,51 @@ (push variable *visible-variables*)))) , at body2))) -(defun rewrite-aux-vars-process-decls (forms arg-vars aux-vars) - (declare (ignore aux-vars)) - (let ((lambda-decls nil) - (let-decls nil)) +(defun split-decls (forms specific-vars) + (let ((other-decls nil) + (specific-decls nil)) (dolist (form forms) (unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen (return)) (dolist (decl (cdr form)) (case (car decl) ((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE) - (push (list 'DECLARE decl) lambda-decls)) + (push (list 'DECLARE decl) other-decls)) (SPECIAL (dolist (name (cdr decl)) - (if (memq name arg-vars) - (push (list 'DECLARE (list 'SPECIAL name)) lambda-decls) - (push (list 'DECLARE (list 'SPECIAL name)) let-decls)))) + (if (memq name specific-vars) + (push `(DECLARE (SPECIAL ,name)) specific-decls) + (push `(DECLARE (SPECIAL ,name)) other-decls)))) (TYPE (dolist (name (cddr decl)) - (if (memq name arg-vars) - (push (list 'DECLARE (list 'TYPE (cadr decl) name)) lambda-decls) - (push (list 'DECLARE (list 'TYPE (cadr decl) name)) let-decls)))) + (if (memq name specific-vars) + (push `(DECLARE (TYPE ,(cadr decl) ,name)) specific-decls) + (push `(DECLARE (TYPE ,(cadr decl) ,name)) other-decls)))) (t (dolist (name (cdr decl)) - (if (memq name arg-vars) - (push (list 'DECLARE (list (car decl) name)) lambda-decls) - (push (list 'DECLARE (list (car decl) name)) let-decls))))))) - (setq lambda-decls (nreverse lambda-decls)) - (setq let-decls (nreverse let-decls)) - (values lambda-decls let-decls))) + (if (memq name specific-vars) + (push `(DECLARE (,(car decl) ,name)) specific-decls) + (push `(DECLARE (,(car decl) ,name)) other-decls))))))) + (values (nreverse other-decls) + (nreverse specific-decls)))) -(defun maybe-rewrite-aux-vars (form) +(defun rewrite-aux-vars (form) (let* ((lambda-list (cadr form)) (lets (cdr (memq '&AUX lambda-list))) aux-vars) (unless lets ;; no rewriting required - (return-from maybe-rewrite-aux-vars form)) + (return-from rewrite-aux-vars form)) (multiple-value-bind (body decls) (parse-body (cddr form)) (dolist (form lets) (cond ((consp form) - (push (%car form) aux-vars)) + (push (car form) aux-vars)) (t (push form aux-vars)))) - (setq lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) (multiple-value-bind (lambda-decls let-decls) - (rewrite-aux-vars-process-decls decls - (lambda-list-names lambda-list) - (nreverse aux-vars)) - `(lambda ,lambda-list + (split-decls decls aux-vars) + `(lambda ,(subseq lambda-list 0 (position '&AUX lambda-list)) , at lambda-decls (let* ,lets , at let-decls @@ -479,7 +474,7 @@ (multiple-value-bind (body decls) (parse-body body) (let* ((block-name (fdefinition-block-name name)) (lambda-expression - (maybe-rewrite-aux-vars + (rewrite-aux-vars `(lambda ,lambda-list , at decls (block ,block-name , at body)))) (*visible-variables* *visible-variables*) (*local-functions* *local-functions*) @@ -507,7 +502,7 @@ :variable variable))) (multiple-value-bind (body decls) (parse-body body) (setf (compiland-lambda-expression compiland) - (maybe-rewrite-aux-vars + (rewrite-aux-vars `(lambda ,lambda-list , at decls (block ,name , at body))))) (push variable *all-variables*) (push local-function local-functions))) @@ -568,7 +563,7 @@ (parse-body body) (setf (compiland-lambda-expression compiland) ;; if there still was a doc-string present, remove it - (maybe-rewrite-aux-vars + (rewrite-aux-vars `(lambda ,lambda-list , at decls , at body))) (let ((*visible-variables* *visible-variables*) (*current-compiland* compiland)) @@ -598,7 +593,7 @@ (compiler-unsupported "P1-LAMBDA: can't handle optional argument with non-constant initform."))))))) (p1-function (list 'FUNCTION - (maybe-rewrite-aux-vars form))))) + (rewrite-aux-vars form))))) (defun p1-eval-when (form) (list* (car form) (cadr form) (mapcar #'p1 (cddr form)))) @@ -915,7 +910,7 @@ ;; (format t "p1-compiland name = ~S~%" (compiland-name compiland)) (let ((form (compiland-lambda-expression compiland))) (aver (eq (car form) 'LAMBDA)) - (setf form (maybe-rewrite-aux-vars form)) + (setf form (rewrite-aux-vars form)) (process-optimization-declarations (cddr form)) (let* ((lambda-list (cadr form)) From ehuelsmann at common-lisp.net Wed Apr 29 21:57:24 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Apr 2009 17:57:24 -0400 Subject: [armedbear-cvs] r11803 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 29 17:57:23 2009 New Revision: 11803 Log: Always rewrite &aux vars, even if there are no vars after &aux: the compiler plainly doesn't want to see &aux in the lambda list. 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 Wed Apr 29 17:57:23 2009 @@ -446,9 +446,10 @@ (defun rewrite-aux-vars (form) (let* ((lambda-list (cadr form)) - (lets (cdr (memq '&AUX lambda-list))) + (aux-p (memq '&AUX lambda-list)) + (lets (cdr aux-p)) aux-vars) - (unless lets + (unless aux-p ;; no rewriting required (return-from rewrite-aux-vars form)) (multiple-value-bind (body decls) From ehuelsmann at common-lisp.net Wed Apr 29 22:00:19 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Apr 2009 18:00:19 -0400 Subject: [armedbear-cvs] r11804 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Apr 29 18:00:18 2009 New Revision: 11804 Log: LET/LET* bindings can be (in case of a CONS) of length 1 or 2 (not only 2). 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 Wed Apr 29 18:00:18 2009 @@ -150,8 +150,10 @@ `(let ((,variables-var ())) (dolist (,varspec ,varlist) (cond ((consp ,varspec) - ;; FIXME Currently this error is signalled by the precompiler. - (unless (= (length ,varspec) 2) + ;; Even though the precompiler already signals this + ;; error, double checking can't hurt; after all, we're + ;; also rewriting &AUX into LET* bindings. + (unless (<= 1 (length ,varspec) 2) (compiler-error "The LET/LET* binding specification ~S is invalid." ,varspec)) (let* ((,name (%car ,varspec)) From ehuelsmann at common-lisp.net Thu Apr 30 06:03:33 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 30 Apr 2009 02:03:33 -0400 Subject: [armedbear-cvs] r11805 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Apr 30 02:03:30 2009 New Revision: 11805 Log: Stop rewriting the lambda list in the precompiler; we've decided this compiler-specific rewrite should be in the compiler. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.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 Thu Apr 30 02:03:30 2009 @@ -469,6 +469,109 @@ , at let-decls , at body)))))) +(defun rewrite-lambda (form) + (setf form (rewrite-aux-vars form)) + (let* ((lambda-list (cadr form))) + (if (not (or (memq '&optional lambda-list) + (memq '&key lambda-list))) + ;; no need to rewrite: no arguments with possible initforms anyway + form + (multiple-value-bind (body decls doc) + (parse-body (cddr form)) + (let (state let-bindings new-lambda-list + (non-constants 0)) + (do* ((vars lambda-list (cdr vars)) + (var (car vars) (car vars))) + ((endp vars)) + (push (car vars) new-lambda-list) + (let ((replacement (gensym))) + (flet ((parse-compound-argument (arg) + "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, + SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument." + (destructuring-bind + (name &optional (initform nil initform-supplied-p) + (supplied-p nil supplied-p-supplied-p)) + (if (listp arg) arg (list arg)) + (if (listp name) + (values (cadr name) (car name) + initform initform-supplied-p + supplied-p supplied-p-supplied-p) + (values name (make-keyword name) + initform initform-supplied-p + supplied-p supplied-p-supplied-p))))) + (case var + (&optional (setf state :optional)) + (&key (setf state :key)) + ((&whole &environment &rest &body &allow-other-keys) + ;; do nothing special + ) + (t + (cond + ((atom var) + (setf (car new-lambda-list) + (if (eq state :key) + (list (list (make-keyword var) replacement)) + replacement)) + (push (list var replacement) let-bindings)) + ((constantp (second var)) + ;; so, we must have a consp-type var we're looking at + ;; and it has a constantp initform + (multiple-value-bind + (name keyword initform initform-supplied-p + supplied-p supplied-p-supplied-p) + (parse-compound-argument var) + (let ((var-form (if (eq state :key) + (list keyword replacement) + replacement)) + (supplied-p-replacement (gensym))) + (setf (car new-lambda-list) + (cond + ((not initform-supplied-p) + (list var-form)) + ((not supplied-p-supplied-p) + (list var-form initform)) + (t + (list var-form initform + supplied-p-replacement)))) + (push (list name replacement) let-bindings) + ;; if there was a 'supplied-p' variable, it might + ;; be used in the declarations. Since those will be + ;; moved below the LET* block, we need to move the + ;; supplied-p parameter too. + (when supplied-p-supplied-p + (push (list supplied-p supplied-p-replacement) + let-bindings))))) + (t + (incf non-constants) + ;; this is either a keyword or an optional argument + ;; with a non-constantp initform + (multiple-value-bind + (name keyword initform initform-supplied-p + supplied-p supplied-p-supplied-p) + (parse-compound-argument var) + (declare (ignore initform-supplied-p)) + (let ((var-form (if (eq state :key) + (list keyword replacement) + replacement)) + (supplied-p-replacement (gensym))) + (setf (car new-lambda-list) + (list var-form nil supplied-p-replacement)) + (push (list name `(if ,supplied-p-replacement + ,replacement ,initform)) + let-bindings) + (when supplied-p-supplied-p + (push (list supplied-p supplied-p-replacement) + let-bindings))))))))))) + (if (zerop non-constants) + ;; there was no reason to rewrite... + form + (let ((rv + `(lambda ,(nreverse new-lambda-list) + ,@(when doc (list doc)) + (let* ,(nreverse let-bindings) + , at decls , at body)))) + rv))))))) + (defun p1-flet (form) (with-local-functions-for-flet/labels form local-functions 'FLET lambda-list name body @@ -477,7 +580,7 @@ (multiple-value-bind (body decls) (parse-body body) (let* ((block-name (fdefinition-block-name name)) (lambda-expression - (rewrite-aux-vars + (rewrite-lambda `(lambda ,lambda-list , at decls (block ,block-name , at body)))) (*visible-variables* *visible-variables*) (*local-functions* *local-functions*) @@ -505,7 +608,7 @@ :variable variable))) (multiple-value-bind (body decls) (parse-body body) (setf (compiland-lambda-expression compiland) - (rewrite-aux-vars + (rewrite-lambda `(lambda ,lambda-list , at decls (block ,name , at body))))) (push variable *all-variables*) (push local-function local-functions))) @@ -566,7 +669,7 @@ (parse-body body) (setf (compiland-lambda-expression compiland) ;; if there still was a doc-string present, remove it - (rewrite-aux-vars + (rewrite-lambda `(lambda ,lambda-list , at decls , at body))) (let ((*visible-variables* *visible-variables*) (*current-compiland* compiland)) @@ -596,7 +699,7 @@ (compiler-unsupported "P1-LAMBDA: can't handle optional argument with non-constant initform."))))))) (p1-function (list 'FUNCTION - (rewrite-aux-vars form))))) + (rewrite-lambda form))))) (defun p1-eval-when (form) (list* (car form) (cadr form) (mapcar #'p1 (cddr form)))) @@ -913,7 +1016,7 @@ ;; (format t "p1-compiland name = ~S~%" (compiland-name compiland)) (let ((form (compiland-lambda-expression compiland))) (aver (eq (car form) 'LAMBDA)) - (setf form (rewrite-aux-vars form)) + (setf form (rewrite-lambda form)) (process-optimization-declarations (cddr form)) (let* ((lambda-list (cadr 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 Thu Apr 30 02:03:30 2009 @@ -551,109 +551,6 @@ ;; Delegate to PRECOMPILE-PSETF so symbol macros are handled correctly. (precompile-psetf form)) -(defun maybe-rewrite-lambda (form) - (let* ((lambda-list (cadr form))) - (if (not (or (memq '&optional lambda-list) - (memq '&key lambda-list))) - ;; no need to rewrite: no arguments with possible initforms anyway - form - (multiple-value-bind (body decls doc) - (parse-body (cddr form)) - (let (state let-bindings new-lambda-list - (non-constants 0)) - (do* ((vars lambda-list (cdr vars)) - (var (car vars) (car vars))) - ((or (endp vars) (eq '&aux (car vars))) - (setf new-lambda-list - (append (reverse vars) new-lambda-list))) - (push (car vars) new-lambda-list) - (let ((replacement (gensym))) - (flet ((parse-compound-argument (arg) - "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, - SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument." - (destructuring-bind - (name &optional (initform nil initform-supplied-p) - (supplied-p nil supplied-p-supplied-p)) - (if (listp arg) arg (list arg)) - (if (listp name) - (values (cadr name) (car name) - initform initform-supplied-p - supplied-p supplied-p-supplied-p) - (values name (make-keyword name) - initform initform-supplied-p - supplied-p supplied-p-supplied-p))))) - (case var - (&optional (setf state :optional)) - (&key (setf state :key)) - ((&whole &environment &rest &body &allow-other-keys) - ;; do nothing special - ) - (t - (cond - ((atom var) - (setf (car new-lambda-list) - (if (eq state :key) - (list (list (make-keyword var) replacement)) - replacement)) - (push (list var replacement) let-bindings)) - ((constantp (second var)) - ;; so, we must have a consp-type var we're looking at - ;; and it has a constantp initform - (multiple-value-bind - (name keyword initform initform-supplied-p - supplied-p supplied-p-supplied-p) - (parse-compound-argument var) - (let ((var-form (if (eq state :key) - (list keyword replacement) - replacement)) - (supplied-p-replacement (gensym))) - (setf (car new-lambda-list) - (cond - ((not initform-supplied-p) - (list var-form)) - ((not supplied-p-supplied-p) - (list var-form initform)) - (t - (list var-form initform - supplied-p-replacement)))) - (push (list name replacement) let-bindings) - ;; if there was a 'supplied-p' variable, it might - ;; be used in the declarations. Since those will be - ;; moved below the LET* block, we need to move the - ;; supplied-p parameter too. - (when supplied-p-supplied-p - (push (list supplied-p supplied-p-replacement) - let-bindings))))) - (t - (incf non-constants) - ;; this is either a keyword or an optional argument - ;; with a non-constantp initform - (multiple-value-bind - (name keyword initform initform-supplied-p - supplied-p supplied-p-supplied-p) - (parse-compound-argument var) - (declare (ignore initform-supplied-p)) - (let ((var-form (if (eq state :key) - (list keyword replacement) - replacement)) - (supplied-p-replacement (gensym))) - (setf (car new-lambda-list) - (list var-form nil supplied-p-replacement)) - (push (list name `(if ,supplied-p-replacement - ,replacement ,initform)) - let-bindings) - (when supplied-p-supplied-p - (push (list supplied-p supplied-p-replacement) - let-bindings))))))))))) - (if (zerop non-constants) - ;; there was no reason to rewrite... - form - (let ((rv - `(lambda ,(nreverse new-lambda-list) - ,@(when doc (list doc)) - (let* ,(nreverse let-bindings) - , at decls , at body)))) - rv))))))) (defun precompile-lambda-list (form) (let (new aux-tail) @@ -678,7 +575,6 @@ (push new-arg new)))))) (defun precompile-lambda (form) - (setq form (maybe-rewrite-lambda form)) (let ((body (cddr form)) (precompiled-lambda-list (precompile-lambda-list (cadr form))) @@ -689,7 +585,6 @@ (defun precompile-named-lambda (form) (let ((lambda-form (list* 'LAMBDA (caddr form) (cdddr form)))) - (setf lambda-form (maybe-rewrite-lambda lambda-form)) (let ((body (cddr lambda-form)) (precompiled-lambda-list (precompile-lambda-list (cadr lambda-form))) @@ -841,11 +736,10 @@ (defun precompile-local-function-def (def) (let ((name (car def)) - (arglist (cadr def)) (body (cddr def))) ;; Macro names are shadowed by local functions. (environment-add-function-definition *compile-file-environment* name body) - (list* name arglist (mapcar #'precompile1 body)))) + (cdr (precompile-named-lambda (list* 'NAMED-LAMBDA def))))) (defun precompile-local-functions (defs) (let ((result nil)) From ehuelsmann at common-lisp.net Thu Apr 30 06:13:36 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 30 Apr 2009 02:13:36 -0400 Subject: [armedbear-cvs] r11806 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Apr 30 02:13:35 2009 New Revision: 11806 Log: Remove compiler warning about non-constant initforms: we support them now! 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 Thu Apr 30 02:13:35 2009 @@ -377,24 +377,12 @@ (setf (block-non-local-go-p tag-block) t))))) form) -(defun validate-name-and-lambda-list (name lambda-list context) +(defun validate-function-name (name) (unless (or (symbolp name) (setf-function-name-p name)) - (compiler-error "~S is not a valid function name." name)) - (when (or (memq '&optional lambda-list) - (memq '&key lambda-list)) - (let ((state nil)) - (dolist (arg lambda-list) - (cond ((memq arg lambda-list-keywords) - (setf state arg)) - ((memq state '(&optional &key)) - (when (and (consp arg) (not (constantp (second arg)))) - (compiler-unsupported - "~A: can't handle ~A argument with non-constant initform." - context - (if (eq state '&optional) "optional" "keyword"))))))))) + (compiler-error "~S is not a valid function name." name))) -(defmacro with-local-functions-for-flet/labels - (form local-functions-var lambda-name lambda-list-var name-var body-var body1 body2) +(defmacro with-local-functions-for-flet/labels + (form local-functions-var lambda-list-var name-var body-var body1 body2) `(progn (incf (compiland-children *current-compiland*) (length (cadr ,form))) (let ((*visible-variables* *visible-variables*) (*local-functions* *local-functions*) @@ -403,8 +391,7 @@ (dolist (definition (cadr ,form)) (let ((,name-var (car definition)) (,lambda-list-var (cadr definition))) - (validate-name-and-lambda-list ,name-var ,lambda-list-var ,lambda-name) - + (validate-function-name ,name-var) (let* ((,body-var (cddr definition)) (compiland (make-compiland :name ,name-var :parent *current-compiland*))) @@ -574,7 +561,7 @@ (defun p1-flet (form) (with-local-functions-for-flet/labels - form local-functions 'FLET lambda-list name body + form local-functions lambda-list name body ((let ((local-function (make-local-function :name name :compiland compiland))) (multiple-value-bind (body decls) (parse-body body) @@ -601,7 +588,7 @@ (defun p1-labels (form) (with-local-functions-for-flet/labels - form local-functions 'LABELS lambda-list name body + form local-functions lambda-list name body ((let* ((variable (make-variable :name (gensym))) (local-function (make-local-function :name name :compiland compiland From ehuelsmann at common-lisp.net Thu Apr 30 06:20:03 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 30 Apr 2009 02:20:03 -0400 Subject: [armedbear-cvs] r11807 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Apr 30 02:20:02 2009 New Revision: 11807 Log: Follow-up on r11802: only put declarations which are explicitly about the argument variables in the lambda and the rest in the LET*; otherwise we may be declaring variables special before we should. 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 Thu Apr 30 02:20:02 2009 @@ -448,9 +448,10 @@ (push (car form) aux-vars)) (t (push form aux-vars)))) - (multiple-value-bind (lambda-decls let-decls) - (split-decls decls aux-vars) - `(lambda ,(subseq lambda-list 0 (position '&AUX lambda-list)) + (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) + (multiple-value-bind (let-decls lambda-decls) + (split-decls decls (lambda-list-names lambda-list)) + `(lambda ,lambda-list , at lambda-decls (let* ,lets , at let-decls From ehuelsmann at common-lisp.net Thu Apr 30 06:47:30 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 30 Apr 2009 02:47:30 -0400 Subject: [armedbear-cvs] r11808 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Apr 30 02:47:29 2009 New Revision: 11808 Log: Fix exporting symbol in a different package than the current one. Found by: Vladimir Korablin 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 Thu Apr 30 02:47:29 2009 @@ -258,11 +258,10 @@ stream compile-time-too)) (return-from process-toplevel-form)) - (when compile-time-too - (eval form)) - (cond ((eq operator 'QUOTE) ;; (setf form (precompile-form form nil)) + (when compile-time-too + (eval form)) (return-from process-toplevel-form) ) ((eq operator 'PUT) @@ -282,6 +281,8 @@ (let ((*package* +keyword-package+)) (dump-form form stream)) (%stream-terpri stream) + (when compile-time-too + (eval form)) (return-from process-toplevel-form)) ((and (eq operator '%SET-FDEFINITION) (eq (car (second form)) 'QUOTE) @@ -309,7 +310,9 @@ ))))))) (when (consp form) (dump-form form stream) - (%stream-terpri stream))) + (%stream-terpri stream)) + (when compile-time-too + (eval form))) (declaim (ftype (function (t) t) convert-ensure-method)) (defun convert-ensure-method (form)