Project page
Testimonials
-Release notes +Release notes

Added: public_html/release-notes-0.16.shtml ============================================================================== --- (empty file) +++ public_html/release-notes-0.16.shtml Sat Sep 5 16:30:14 2009 @@ -0,0 +1,152 @@ + + + + +  + + + + + + + + + + +

+ +

Release notes for ABCL 0.16

+ Major changes and new features +

Improved THE type checking: The compiler outputs type checks for simple enough types at + *safety* levels 1 and 2 now.
+ The interpreter checks simple enough types at all *safety* levels
ANSI test fixes: Fixed tests due to better initarg checking:
+ CHANGE-CLASS.1.11, MAKE-INSTANCE.ERROR.3, MAKE-INSTANCE.ERROR.4, + CHANGE-CLASS.ERROR.4 and SHARED-INITIALIZE.ERROR.4
Added JVM threading primitives: SYNCHRONIZED-ON, OBJECT-NOTIFY, OBJECT-NOTIFY-ALL equivalents of + the Java synchronized block, Object.notify() and Object.notifyAll()
New THREADS package to hold threading primitives: The symbols are retained in the old EXTENSIONS package until 0.22
Type checking for structure slot accessor functions: The generated accessor functions for structure slots now assert + the type of the argument passed in using a THE form
Fixed breakage when combining the pretty printer and Gray streams: The fixes mean changes to the generic functions in Gray streams + to compensate for the fact that the pretty printer wraps streams.
Various performance improvements

+ + +

Release notes for ABCL 0.15

+ Major changes and new features +

Fixed special bindings un-binding in compiled code for (local) + transfer of control using GO/RETURN-FROM: Special bindings now will get unbound in many more cases and much + more efficiently upon local transfer of control. +
Reduced ANSI failures in both compiled and interpreted modes: MULTIPLE-VALUE-SETQ wasn't working correctly on symbol macros. + Multiple issues with DEFINE-SETF-EXPANDER, and others. See CHANGES. +
Multiple JSR-233 (Java scripting) support fixes: See the logs for more: too much to summarize. +
Compiler new feature: Support for COMPILE-ing functions with non-empty lexical environments - + which themselves are not being compiled. +
Google App Engine: Don't break when being run on Google App Engine because 'os.arch' + isn't set. +
COMPILER-LET and MACROEXPAND-ALL: CLtL2 primitive COMPILER-LET is now supported in the EXT package, + so is MACROEXPAND-ALL. +

+ +

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$

+ + Added: public_html/releases/abcl-src-0.16.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.16.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.16.0.tar.gz.asc Sat Sep 5 16:30:14 2009 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkqiwjgACgkQi5O0Epaz9Tke+ACcDGj/qgfxSbrKHqOY+YE+phG1 +abAAn0+S2gHl7P0tloDaE/O9ex8B4o5y +=3mLv +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.16.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.16.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.16.0.zip.asc Sat Sep 5 16:30:14 2009 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkqiwkIACgkQi5O0Epaz9TlJMQCfdhmJYkeoxQD64uaCc6+lpy0a ++bEAmQFx/09SDE8lphHkSG9mQLn15oqM +=zv3i +-----END PGP SIGNATURE----- From ehuelsmann at common-lisp.net Sun Sep 6 13:57:40 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Sep 2009 09:57:40 -0400 Subject: [armedbear-cvs] r12134 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 6 09:57:37 2009 New Revision: 12134 Log: Fix typo (double 'with'). Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp 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 Sun Sep 6 09:57:37 2009 @@ -161,7 +161,7 @@ p1-result ; the parse tree as created in pass 1 parent ; the parent for compilands which defined within another (children 0 ; Number of local functions - :type fixnum) ; defined with with FLET, LABELS or LAMBDA + :type fixnum) ; defined with FLET, LABELS or LAMBDA blocks ; TAGBODY, PROGV, BLOCK, etc. blocks argument-register closure-register From ehuelsmann at common-lisp.net Sun Sep 6 13:58:47 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Sep 2009 09:58:47 -0400 Subject: [armedbear-cvs] r12135 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 6 09:58:46 2009 New Revision: 12135 Log: Rename function (it's not applicable to FLET); move it closer where it's actually used. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Sep 6 09:58:46 2009 @@ -4891,20 +4891,6 @@ (compile-and-write-to-file class-file compiland)) -(defun emit-make-compiled-closure-for-flet/labels - (local-function compiland declaration) - (emit 'getstatic *this-class* declaration +lisp-object+) - (let ((parent (compiland-parent compiland))) - (when (compiland-closure-register parent) - (dformat t "(compiland-closure-register parent) = ~S~%" - (compiland-closure-register parent)) - (emit 'checkcast +lisp-compiled-closure-class+) - (duplicate-closure-array parent) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+))) - (emit-move-to-variable (local-function-variable local-function))) - (defmacro with-temp-class-file (pathname class-file lambda-list &body body) `(let* ((,pathname (make-temp-file)) (,class-file (make-class-file :pathname ,pathname @@ -4931,6 +4917,20 @@ (setf (local-function-function local-function) (load-compiled-function pathname))))))) +(defun emit-make-compiled-closure-for-labels + (local-function compiland declaration) + (emit 'getstatic *this-class* declaration +lisp-object+) + (let ((parent (compiland-parent compiland))) + (when (compiland-closure-register parent) + (dformat t "(compiland-closure-register parent) = ~S~%" + (compiland-closure-register parent)) + (emit 'checkcast +lisp-compiled-closure-class+) + (duplicate-closure-array parent) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +closure-binding-array+) + +lisp-object+))) + (emit-move-to-variable (local-function-variable local-function))) + (defknown p2-labels-process-compiland (t) t) (defun p2-labels-process-compiland (local-function) (let* ((compiland (local-function-compiland local-function)) @@ -4942,7 +4942,7 @@ (set-compiland-and-write-class-file class-file compiland) (setf (local-function-class-file local-function) class-file) (let ((g (declare-local-function local-function))) - (emit-make-compiled-closure-for-flet/labels + (emit-make-compiled-closure-for-labels local-function compiland g)))) (t (with-temp-class-file @@ -4950,7 +4950,7 @@ (set-compiland-and-write-class-file class-file compiland) (setf (local-function-class-file local-function) class-file) (let ((g (declare-object (load-compiled-function pathname)))) - (emit-make-compiled-closure-for-flet/labels + (emit-make-compiled-closure-for-labels local-function compiland g))))))) (defknown p2-flet-node (t t t) t) From ehuelsmann at common-lisp.net Sun Sep 6 14:54:43 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Sep 2009 10:54:43 -0400 Subject: [armedbear-cvs] r12136 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 6 10:54:42 2009 New Revision: 12136 Log: Clean up BLOCK-NODE handling and p2-block-node; remove RETURN-P and CATCH-TAG slots. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.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/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Sep 6 10:54:42 2009 @@ -361,7 +361,6 @@ (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible." name name)) (dformat t "p1-return-from block = ~S~%" (block-name block)) - (setf (block-return-p block) t) (cond ((eq (block-compiland block) *current-compiland*) ;; Local case. If the RETURN is nested inside an UNWIND-PROTECT ;; which is inside the block we're returning from, we'll do a non- Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Sep 6 10:54:42 2009 @@ -4642,50 +4642,42 @@ (sys::%format t "type-of block = ~S~%" (type-of block)) (aver (block-node-p block))) (let* ((*blocks* (cons block *blocks*)) - (*register* *register*)) - (if (null (block-return-p block)) - ;; No explicit returns - (compile-progn-body (cddr (block-form block)) target representation) - (progn - (setf (block-target block) target) - (dformat t "p2-block-node lastSpecialBinding~%") - (dformat t "*all-variables* = ~S~%" - (mapcar #'variable-name *all-variables*)) - (setf (block-catch-tag block) (gensym)) - (let* ((*register* *register*) - (BEGIN-BLOCK (gensym)) - (END-BLOCK (gensym)) - (BLOCK-EXIT (block-exit block))) - (label BEGIN-BLOCK) ; Start of protected range. - ;; Implicit PROGN. - (compile-progn-body (cddr (block-form block)) target) - (label END-BLOCK) ; End of protected range. - (emit 'goto BLOCK-EXIT) ; Jump over handler (if any). - (when (block-non-local-return-p block) - ;; We need a handler to catch non-local RETURNs. - (let ((HANDLER (gensym)) - (RETHROW (gensym))) - (label HANDLER) - ;; The Return object is on the runtime stack. Stack depth is 1. - (emit 'dup) ; Stack depth is 2. - (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2. - (compile-form `',(block-catch-tag block) 'stack nil) ; Tag. Stack depth is 3. - ;; If it's not the tag we're looking for... - (emit 'if_acmpne RETHROW) ; Stack depth is 1. - (emit 'getfield +lisp-return-class+ "result" +lisp-object+) - (emit-move-from-stack target) ; Stack depth is 0. - (emit 'goto BLOCK-EXIT) - (label RETHROW) - ;; Not the tag we're looking for. - (emit 'athrow) - ;; Finally... - (push (make-handler :from BEGIN-BLOCK - :to END-BLOCK - :code HANDLER - :catch-type (pool-class +lisp-return-class+)) - *handlers*))) - (label BLOCK-EXIT)) - (fix-boxing representation nil))))) + (BEGIN-BLOCK (gensym)) + (END-BLOCK (gensym)) + (BLOCK-EXIT (block-exit block))) + (setf (block-target block) target) + (dformat t "*all-variables* = ~S~%" + (mapcar #'variable-name *all-variables*)) + (label BEGIN-BLOCK) ; Start of protected range, for non-local returns + ;; Implicit PROGN. + (compile-progn-body (cddr (block-form block)) target) + (label END-BLOCK) ; End of protected range, for non-local returns + (when (block-non-local-return-p block) + ;; We need a handler to catch non-local RETURNs. + (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one + (let ((HANDLER (gensym)) + (RETHROW (gensym))) + (label HANDLER) + ;; The Return object is on the runtime stack. Stack depth is 1. + (emit 'dup) ; Stack depth is 2. + (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2. + (compile-form `',(block-exit block) 'stack nil) ; Tag. Stack depth is 3. + ;; If it's not the tag we're looking for... + (emit 'if_acmpne RETHROW) ; Stack depth is 1. + (emit 'getfield +lisp-return-class+ "result" +lisp-object+) + (emit-move-from-stack target) ; Stack depth is 0. + (emit 'goto BLOCK-EXIT) + (label RETHROW) + ;; Not the tag we're looking for. + (emit 'athrow) + ;; Finally... + (push (make-handler :from BEGIN-BLOCK + :to END-BLOCK + :code HANDLER + :catch-type (pool-class +lisp-return-class+)) + *handlers*))) + (label BLOCK-EXIT) + (fix-boxing representation nil))) (defknown p2-return-from (t t t) t) (defun p2-return-from (form target representation) @@ -4716,7 +4708,7 @@ (cond ((node-constant-p result-form) (emit 'new +lisp-return-class+) (emit 'dup) - (compile-form `',(block-catch-tag block) 'stack nil) ; Tag. + (compile-form `',(block-exit block) 'stack nil) ; Tag. (emit-clear-values) (compile-form result-form 'stack nil)) ; Result. (t @@ -4726,7 +4718,7 @@ (compile-form result-form temp-register nil) ; Result. (emit 'new +lisp-return-class+) (emit 'dup) - (compile-form `',(block-catch-tag block) 'stack nil) ; Tag. + (compile-form `',(block-exit block) 'stack nil) ; Tag. (aload temp-register)))) (emit-invokespecial-init +lisp-return-class+ (lisp-object-arg-types 2)) (emit 'athrow) @@ -6413,6 +6405,10 @@ t))))) ((node-p form) (let ((result t)) +;;; ### FIXME +#| +the statements below used to work, maybe ... +We need more thought here. (cond ((and (block-node-p form) (equal (block-name form) '(LET))) ;; (format t "derive-type LET/LET* node case~%") @@ -6436,7 +6432,7 @@ ;; (format t "last-form = ~S~%" last-form)) ;; (format t "derived-type = ~S~%" derived-type) ;; ) - (setf result derived-type))))) + (setf result derived-type))))) |# result)) (t t))) 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 Sun Sep 6 10:54:42 2009 @@ -430,13 +430,9 @@ (defstruct (block-node (:conc-name block-) (:include control-transferring-node) (:constructor %make-block-node (name))) - ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND). - name + name ;; Block name (exit (gensym)) target - catch-tag - ;; True if there is any RETURN from this block. - return-p ;; True if there is a non-local RETURN from this block. non-local-return-p) From ehuelsmann at common-lisp.net Sun Sep 6 14:56:24 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Sep 2009 10:56:24 -0400 Subject: [armedbear-cvs] r12137 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 6 10:56:22 2009 New Revision: 12137 Log: Remove stale BLOCK-NODE comments and move it to where it should be according to other comments. Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp 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 Sun Sep 6 10:56:22 2009 @@ -385,7 +385,14 @@ ;; fixme? tag gotten from the catch-form ) -;; block-node belongs here; it's down below for historical raisins +(defstruct (block-node (:conc-name block-) + (:include control-transferring-node) + (:constructor %make-block-node (name))) + name ;; Block name + (exit (gensym)) + target + ;; True if there is a non-local RETURN from this block. + non-local-return-p) ;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY @@ -425,17 +432,6 @@ (:include protected-node))) -;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as -;; BLOCKs per se. -(defstruct (block-node (:conc-name block-) - (:include control-transferring-node) - (:constructor %make-block-node (name))) - name ;; Block name - (exit (gensym)) - target - ;; True if there is a non-local RETURN from this block. - non-local-return-p) - (defvar *blocks* ()) (defknown make-block-node (t) t) From ehuelsmann at common-lisp.net Sun Sep 6 15:22:52 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Sep 2009 11:22:52 -0400 Subject: [armedbear-cvs] r12138 - public_html Message-ID: Author: ehuelsmann Date: Sun Sep 6 11:22:48 2009 New Revision: 12138 Log: Remove mention of SourceForge: it's no longer hosted there. Incorporate hint from tcr, who thinks our download link isn't clearly visible. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sun Sep 6 11:22:48 2009 @@ -31,12 +31,11 @@ Additionally, it can be used to implement (parts of) the application using Java to Lisp integration APIs. - -Download your copy from SourceForge: 0.16.0 +Download 0.16.0 (zip) +style="font-size:75%;color:black;font-weight:normal">(zip) Users (development with ABCL) From ehuelsmann at common-lisp.net Sun Sep 6 20:22:45 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Sep 2009 16:22:45 -0400 Subject: [armedbear-cvs] r12139 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 6 16:22:41 2009 New Revision: 12139 Log: Make it possible to have non-private fields. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Sep 6 16:22:41 2009 @@ -1904,11 +1904,16 @@ (write-u2 (field-descriptor-index field) stream) (write-u2 0 stream)) ; attributes count -(defknown declare-field (t t) t) -(defun declare-field (name descriptor) +(defconst +field-access-protected+ #x4) ;; subclass accessible +(defconst +field-access-private+ #x2) ;; class-only accessible +(defconst +field-access-public+ #x1) ;; generally accessible +(defconst +field-access-default+ #x0) ;; package accessible, used for LABELS + +(defknown declare-field (t t t) t) +(defun declare-field (name descriptor access-flags) (let ((field (make-field name descriptor))) - ;; final private static - (setf (field-access-flags field) (logior #x10 #x8 #x2)) + ;; final static + (setf (field-access-flags field) (logior #x10 #x8 access-flags)) (setf (field-name-index field) (pool-name (field-name field))) (setf (field-descriptor-index field) (pool-name (field-descriptor field))) (push field *fields*))) @@ -1958,7 +1963,7 @@ (setf g (symbol-name (gensym "SYM"))) (when s (setf g (concatenate 'string g "_" s))) - (declare-field g +lisp-symbol+) + (declare-field g +lisp-symbol+ +field-access-private+) (emit 'ldc (pool-string (symbol-name symbol))) (emit 'ldc (pool-string (package-name (symbol-package symbol)))) (emit-invokestatic +lisp-class+ "internInPackage" @@ -1984,7 +1989,7 @@ symbol *declared-symbols* ht g (let ((*code* *static-code*)) (setf g (symbol-name (gensym "KEY"))) - (declare-field g +lisp-symbol+) + (declare-field g +lisp-symbol+ +field-access-private+) (emit 'ldc (pool-string (symbol-name symbol))) (emit-invokestatic +lisp-class+ "internKeyword" (list +java-string+) +lisp-symbol+) @@ -2001,7 +2006,7 @@ (let ((s (sanitize symbol))) (when s (setf f (concatenate 'string f "_" s)))) - (declare-field f +lisp-object+) + (declare-field f +lisp-object+ +field-access-private+) (multiple-value-bind (name class) (lookup-or-declare-symbol symbol) @@ -2028,7 +2033,7 @@ (setf g (symbol-name (gensym "LFUN"))) (let* ((pathname (class-file-pathname (local-function-class-file local-function))) (*code* *static-code*)) - (declare-field g +lisp-object+) + (declare-field g +lisp-object+ +field-access-default+) (emit 'ldc (pool-string (file-namestring pathname))) (emit-invokestatic +lisp-class+ "loadCompiledFunction" (list +java-string+) +lisp-object+) @@ -2045,7 +2050,7 @@ (setf g (format nil "FIXNUM_~A~D" (if (minusp n) "MINUS_" "") (abs n))) - (declare-field g +lisp-integer+) + (declare-field g +lisp-integer+ +field-access-private+) (cond ((<= 0 n 255) (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) (emit-push-constant-int n) @@ -2063,7 +2068,7 @@ n *declared-integers* ht g (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym)))) (let ((*code* *static-code*)) - (declare-field g +lisp-integer+) + (declare-field g +lisp-integer+ +field-access-private+) (cond ((<= most-negative-java-long n most-positive-java-long) ;; (setf g (format nil "BIGNUM_~A~D" ;; (if (minusp n) "MINUS_" "") @@ -2088,7 +2093,7 @@ s *declared-floats* ht g (let* ((*code* *static-code*)) (setf g (concatenate 'string "FLOAT_" (symbol-name (gensym)))) - (declare-field g +lisp-single-float+) + (declare-field g +lisp-single-float+ +field-access-private+) (emit 'new +lisp-single-float-class+) (emit 'dup) (emit 'ldc (pool-float s)) @@ -2103,7 +2108,7 @@ d *declared-doubles* ht g (let ((*code* *static-code*)) (setf g (concatenate 'string "DOUBLE_" (symbol-name (gensym)))) - (declare-field g +lisp-double-float+) + (declare-field g +lisp-double-float+ +field-access-private+) (emit 'new +lisp-double-float-class+) (emit 'dup) (emit 'ldc2_w (pool-double d)) @@ -2117,7 +2122,7 @@ (let ((g (symbol-name (gensym "CHAR"))) (n (char-code c)) (*code* *static-code*)) - (declare-field g +lisp-character+) + (declare-field g +lisp-character+ +field-access-private+) (cond ((<= 0 n 255) (emit 'getstatic +lisp-character-class+ "constants" +lisp-character-array+) (emit-push-constant-int n) @@ -2137,7 +2142,7 @@ (let* ((g (symbol-name (gensym "OBJSTR"))) (s (with-output-to-string (stream) (dump-form obj stream))) (*code* *static-code*)) - (declare-field g obj-ref) + (declare-field g obj-ref +field-access-private+) (emit 'ldc (pool-string s)) (emit-invokestatic +lisp-class+ "readObjectFromString" (list +java-string+) +lisp-object+) @@ -2151,7 +2156,7 @@ (let* ((g (symbol-name (gensym "LTV"))) (s (with-output-to-string (stream) (dump-form obj stream))) (*code* *static-code*)) - (declare-field g +lisp-object+) + (declare-field g +lisp-object+ +field-access-private+) (emit 'ldc (pool-string s)) (emit-invokestatic +lisp-class+ "readObjectFromString" (list +java-string+) +lisp-object+) @@ -2169,7 +2174,7 @@ (let* ((g (symbol-name (gensym "INSTANCE"))) (s (with-output-to-string (stream) (dump-form obj stream))) (*code* *static-code*)) - (declare-field g +lisp-object+) + (declare-field g +lisp-object+ +field-access-private+) (emit 'ldc (pool-string s)) (emit-invokestatic +lisp-class+ "readObjectFromString" (list +java-string+) +lisp-object+) @@ -2185,7 +2190,7 @@ (*print-length* nil) (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj))) (*code* *static-code*)) - (declare-field g +lisp-object+) + (declare-field g +lisp-object+ +field-access-private+) (emit 'ldc (pool-string s)) (emit-invokestatic +lisp-class+ "readObjectFromString" (list +java-string+) +lisp-object+) @@ -2205,7 +2210,7 @@ (let* ((g1 (declare-string key)) (g2 (symbol-name (gensym "O2BJ")))) (let* ((*code* *static-code*)) - (declare-field g2 obj-ref) + (declare-field g2 obj-ref +field-access-private+) (emit 'getstatic *this-class* g1 +lisp-simple-string+) (emit-invokestatic +lisp-class+ "recall" (list +lisp-simple-string+) +lisp-object+) @@ -2221,7 +2226,7 @@ (*print-length* nil) (s (format nil "~S" obj)) (*code* *static-code*)) - (declare-field g +lisp-object+) + (declare-field g +lisp-object+ +field-access-private+) (emit 'ldc (pool-string s)) (emit-invokestatic +lisp-class+ "readObjectFromString" @@ -2237,7 +2242,7 @@ string *declared-strings* ht g (let ((*code* *static-code*)) (setf g (symbol-name (gensym "STR"))) - (declare-field g +lisp-simple-string+) + (declare-field g +lisp-simple-string+ +field-access-private+) (emit 'new +lisp-simple-string-class+) (emit 'dup) (emit 'ldc (pool-string string)) From ehuelsmann at common-lisp.net Sun Sep 6 20:41:11 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 06 Sep 2009 16:41:11 -0400 Subject: [armedbear-cvs] r12140 - branches/variable-less-labels Message-ID: Author: ehuelsmann Date: Sun Sep 6 16:41:09 2009 New Revision: 12140 Log: Create a branch to try to eliminate variables used for LABELS compilation. Added: branches/variable-less-labels/ - copied from r12139, /trunk/ From mevenson at common-lisp.net Wed Sep 9 10:26:23 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 09 Sep 2009 06:26:23 -0400 Subject: [armedbear-cvs] r12141 - in trunk/abcl: . src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Wed Sep 9 06:26:15 2009 New Revision: 12141 Log: Added support for loading Lisp from JAR files. Pathnames passed to LOAD may now specify loading from within JAR files by using the 'jar:file:' uri schema: (load "jar:file:///PATH/TO.jar!/foo") would attempt to load Lisp "associated" with 'foo' in a JAR file located '/PATH/TO.jar'. "Associated with" means that the the following entries in the JAR are looked for: 1) 'foo._' (the initial FASL from compiling 'foo.lisp) 2) 'foo.abcl' (the packed FASL) 3) 'foo.lisp' Associated tests have been included but currently only work under UNIX due to the need to package up the FASLs for testing. Added: trunk/abcl/test/lisp/abcl/bar.lisp trunk/abcl/test/lisp/abcl/eek.lisp trunk/abcl/test/lisp/abcl/foo.lisp trunk/abcl/test/lisp/abcl/load.lisp trunk/abcl/test/lisp/abcl/package-load.sh Modified: trunk/abcl/abcl.asd trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Utilities.java trunk/abcl/test/lisp/abcl/package.lisp Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Wed Sep 9 06:26:15 2009 @@ -9,24 +9,24 @@ ;;; Wrapper for all ABCL ASDF definitions. (defsystem :abcl :version "0.3.0") -(defmethod perform :after ((o load-op) (c (eql (find-system 'abcl)))) +(defmethod perform :after ((o load-op) (c (eql (find-system :abcl)))) ;;; Additional test suite loads would go here. - (asdf:oos 'asdf:load-op :test-abcl :force t)) + (operate 'load-op :test-abcl :force t)) -(defmethod perform ((o test-op) (c (eql (find-system 'abcl)))) +(defmethod perform ((o test-op) (c (eql (find-system :abcl)))) ;;; Additional test suite invocations would go here. - (asdf:oos 'asdf:test-op :ansi-compiled :force t)) + (operate 'test-op :ansi-compiled :force t)) ;;; A collection of test suites for ABCL. (defsystem :test-abcl :version "0.3" :depends-on (:ansi-compiled #+nil :abcl-tests)) -(defmethod perform :after ((o load-op) (c (eql (find-system 'test-abcl)))) +(defmethod perform :after ((o load-op) (c (eql (find-system :test-abcl)))) #+nil (asdf:oos 'asdf:test-op :cl-bench :force t) - (asdf:oos 'asdf:load-op :abcl-test-lisp :force t) - (asdf:oos 'asdf:load-op :ansi-compiled :force t) - (asdf:oos 'asdf:load-op :ansi-interpreted :force t)) + (operate 'load-op :abcl-test-lisp :force t) + (operate 'load-op :ansi-compiled :force t) + (operate 'load-op :ansi-interpreted :force t)) (defsystem :ansi-test :version "1.0" :components ;;; GCL ANSI test suite. @@ -34,14 +34,14 @@ ((:file "package"))))) (defsystem :ansi-interpreted :version "1.0" :depends-on (ansi-test)) -(defmethod perform ((o test-op) (c (eql (find-system 'ansi-interpreted)))) +(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) :abcl.test.ansi) :compile-tests nil)) (defsystem :ansi-compiled :version "1.0" :depends-on (ansi-test)) -(defmethod perform ((o test-op) (c (eql (find-system 'ansi-compiled)))) +(defmethod perform ((o test-op) (c (eql (find-system :ansi-compiled)))) "Invoke tests with: (asdf:oos 'asdf:test-op :abcl-compiled :force t)." (funcall (intern (symbol-name 'run) :abcl.test.ansi) :compile-tests t)) 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 Sep 9 06:26:15 2009 @@ -39,6 +39,7 @@ import java.io.InputStream; import java.lang.reflect.Constructor; import java.math.BigInteger; +import java.net.MalformedURLException; import java.net.URL; import java.net.URLDecoder; import java.util.Hashtable; @@ -118,7 +119,7 @@ PACKAGE_LISP.usePackage(PACKAGE_CL); PACKAGE_LISP.usePackage(PACKAGE_EXT); PACKAGE_LISP.usePackage(PACKAGE_SYS); - PACKAGE_THREADS.usePackage(PACKAGE_CL); + PACKAGE_THREADS.usePackage(PACKAGE_CL); } catch (Throwable t) { @@ -330,7 +331,7 @@ int last = frames.length - 1; for (int i = 0; i<= last; i++) { if (frames[i].getClassName().startsWith("org.armedbear.lisp.Primitive")) - last = i; + last = i; } // Do not include the first three frames: // Thread.getStackTrace, LispThread.getJavaStackTrace, @@ -882,7 +883,7 @@ if (obj instanceof StackFrame) return (StackFrame) obj; return (StackFrame)// Not reached. - type_error(obj, Symbol.STACK_FRAME); + type_error(obj, Symbol.STACK_FRAME); } static @@ -1074,8 +1075,20 @@ } if (device instanceof Pathname) { - // We're loading a fasl from j.jar. + // Are we loading a fasl from j.jar? + // XXX this will collide with file names from other JAR files URL url = Lisp.class.getResource(namestring); + if (url == null) { + // Maybe device-->namestring references another JAR file? + String jarFile = ((Pathname)device).getNamestring(); + if (jarFile.startsWith("jar:file:")) { + try { + url = new URL(jarFile + "!/" + namestring); + } catch (MalformedURLException ex) { + Debug.trace(ex); + } + } + } if (url != null) { try @@ -1111,6 +1124,20 @@ LispObject obj = loadCompiledFunction(in, (int) size); return obj != null ? obj : NIL; } + else + { + // ASSERT type = "abcl" + entryName + = defaultPathname.name.getStringValue() + + "." + "abcl";//defaultPathname.type.getStringValue(); + byte in[] + = Utilities + .getZippedZipEntryAsByteArray(zipFile, + entryName, + namestring); + LispObject o = loadCompiledFunction(in); + return o != null ? o : NIL; + } } finally { Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Wed Sep 9 06:26:15 2009 @@ -33,6 +33,8 @@ package org.armedbear.lisp; +import java.io.ByteArrayInputStream; +import java.io.ByteArrayOutputStream; import java.io.File; import java.io.FileInputStream; import java.io.FileNotFoundException; @@ -43,6 +45,7 @@ import java.util.zip.ZipEntry; import java.util.zip.ZipException; import java.util.zip.ZipFile; +import java.util.zip.ZipInputStream; public final class Load extends Lisp { @@ -56,27 +59,27 @@ Symbol.LOAD_PRINT.symbolValue(thread) != NIL, true); } - + private static final File findLoadableFile(final String filename, final String dir) { File file = new File(dir, filename); - if (!file.isFile()) { - String extension = getExtension(filename); - if (extension == null) { - // No extension specified. Try appending ".lisp" or ".abcl". - File lispFile = new File(dir, filename.concat(".lisp")); - File abclFile = new File(dir, filename.concat(".abcl")); - if (lispFile.isFile() && abclFile.isFile()) { - if (abclFile.lastModified() > lispFile.lastModified()) { - return abclFile; - } else { - return lispFile; - } - } else if (abclFile.isFile()) { - return abclFile; - } else if (lispFile.isFile()) { - return lispFile; + if (!file.isFile()) { + String extension = getExtension(filename); + if (extension == null) { + // No extension specified. Try appending ".lisp" or ".abcl". + File lispFile = new File(dir, filename.concat(".lisp")); + File abclFile = new File(dir, filename.concat(".abcl")); + if (lispFile.isFile() && abclFile.isFile()) { + if (abclFile.lastModified() > lispFile.lastModified()) { + return abclFile; + } else { + return lispFile; + } + } else if (abclFile.isFile()) { + return abclFile; + } else if (lispFile.isFile()) { + return lispFile; } } } else @@ -84,60 +87,131 @@ return null; // this is the error case: the file does not exist // no need to check again at the caller } - + public static final LispObject load(Pathname pathname, String filename, boolean verbose, boolean print, boolean ifDoesNotExist) throws ConditionThrowable { - return load(pathname, filename, verbose, print, ifDoesNotExist, false); + return load(pathname, filename, verbose, print, ifDoesNotExist, false); } - public static final LispObject load(Pathname pathname, String filename, boolean verbose, boolean print, boolean ifDoesNotExist, - boolean returnLastResult) + boolean returnLastResult) throws ConditionThrowable { - String dir = null; + String dir = null; if (!Utilities.isFilenameAbsolute(filename)) { - dir = - coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()).getNamestring(); + dir = coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS + .symbolValue()).getNamestring(); + } + + String zipFileName = null; + String zipEntryName = null; + if (filename.startsWith("jar:file:")) { + String s = new String(filename); + s = s.substring(9); + int index = s.lastIndexOf('!'); + if (index >= 0) { + zipFileName = s.substring(0, index); + zipEntryName = s.substring(index + 1); + if (zipEntryName.length() > 0 && zipEntryName.charAt(0) == '/') + zipEntryName = zipEntryName.substring(1); + if (Utilities.isPlatformWindows) { + if (zipFileName.length() > 0 && zipFileName.charAt(0) == '/') + zipFileName = zipFileName.substring(1); + } + } } - File file = findLoadableFile(filename, dir); - if (file == null) { + File file = findLoadableFile(filename, dir); + if (null == file && null == zipFileName) { if (ifDoesNotExist) - return error(new FileError("File not found: " + filename, - pathname)); + return error(new FileError("File not found: " + filename, pathname)); else return NIL; } - filename = file.getPath(); + if (checkZipFile(file)) { + // Either we are loading a packed FASL (i.e. ZIP with suffix ".abcl") + // Or we are loading from a JAR archive + if (".abcl".equals(getExtension(file.getPath()))) { + // So we adjust the value passed to + // loadFileFromStream() to get any further loading + // within this invocation of LOAD to work properly. + filename = file.getPath(); + } + zipFileName = file.getPath(); + zipEntryName = file.getName(); + } + + String truename = filename; ZipFile zipfile = null; - if (checkZipFile(file)) - { + + boolean packedFASL = false; + + InputStream in = null; + if (zipFileName != null) { try { - zipfile = ZipCache.getZip(file.getPath()); + zipfile = ZipCache.getZip(zipFileName); } catch (Throwable t) { - // Fall through. + return error (new FileError("Zip file not found: " + filename, pathname)); } - } - String truename = filename; - InputStream in = null; - if (zipfile != null) { - String name = file.getName(); - int index = name.lastIndexOf('.'); - Debug.assertTrue(index >= 0); - name = name.substring(0, index).concat("._"); - ZipEntry entry = zipfile.getEntry(name); - if (entry != null) { + ZipEntry entry = zipfile.getEntry(zipEntryName); + if (null == entry) { + // try appending "._" to base filename + int index = zipEntryName.lastIndexOf('.'); + if (-1 == index) index = zipEntryName.length(); + zipEntryName = zipEntryName.substring(0, index).concat("._"); + entry = zipfile.getEntry(zipEntryName); + } + if (null == entry) { + // try appending ".abcl" to base filename + int index = zipEntryName.lastIndexOf('.'); + if (index == -1) + index = zipEntryName.length(); + zipEntryName = zipEntryName.substring(0, index).concat(".abcl"); + entry = zipfile.getEntry(zipEntryName); + if (entry != null) + packedFASL = true; + } + if (null == entry) { + // Try looking for ".lisp" + int i = zipEntryName.lastIndexOf('.'); + if (i == -1) { + i = zipEntryName.length(); + } + zipEntryName = zipEntryName.substring(0, i).concat(".lisp"); + entry = zipfile.getEntry(zipEntryName); + if (entry == null) { + return error(new LispError("Failed to find " + zipEntryName + " in " + + zipFileName + ".")); + } + } + + if (null == entry) { + return error(new FileError("Can't find zip file entry " + + zipEntryName, pathname)); + } + if (".abcl".equals(getExtension(zipEntryName))) { + packedFASL = true; + } + if (packedFASL) { + // If we are loading a packed FASL from the JAR we + // have to decompress it first, and seek for the '._' + // init FASL. + int i = zipEntryName.lastIndexOf('.'); + String subZipEntryName = zipEntryName.substring(0, i).concat("._"); + in = Utilities.getZippedZipEntryAsInputStream(zipfile, + zipEntryName, + subZipEntryName); + } else { try { in = zipfile.getInputStream(entry); } @@ -162,9 +236,10 @@ } } try { - return loadFileFromStream(null, truename, - new Stream(in, Symbol.CHARACTER), - verbose, print, false, returnLastResult); + + return loadFileFromStream(null, truename, + new Stream(in, Symbol.CHARACTER), + verbose, print, false, returnLastResult); } catch (FaslVersionMismatch e) { FastStringBuffer sb = @@ -391,8 +466,8 @@ boolean verbose, boolean print, boolean auto) - throws ConditionThrowable { - return loadFileFromStream(pathname, truename, in, verbose, print, auto, false); + throws ConditionThrowable { + return loadFileFromStream(pathname, truename, in, verbose, print, auto, false); } private static final LispObject loadFileFromStream(LispObject pathname, @@ -401,7 +476,7 @@ boolean verbose, boolean print, boolean auto, - boolean returnLastResult) + boolean returnLastResult) throws ConditionThrowable { long start = System.currentTimeMillis(); @@ -466,8 +541,8 @@ private static final LispObject loadStream(Stream in, boolean print, LispThread thread) - throws ConditionThrowable { - return loadStream(in, print, thread, false); + throws ConditionThrowable { + return loadStream(in, print, thread, false); } private static final LispObject loadStream(Stream in, boolean print, @@ -482,7 +557,7 @@ thread.lastSpecialBinding = sourcePositionBinding; try { final Environment env = new Environment(); - LispObject result = NIL; + LispObject result = NIL; while (true) { sourcePositionBinding.value = Fixnum.getInstance(in.getOffset()); LispObject obj = in.read(false, EOF, false, thread); @@ -496,11 +571,11 @@ out._finishOutput(); } } - if(returnLastResult) { - return result; - } else { - return T; - } + if(returnLastResult) { + return result; + } else { + return T; + } } finally { thread.lastSpecialBinding = lastSpecialBinding; @@ -513,7 +588,7 @@ Stream in = (Stream) _LOAD_STREAM_.symbolValue(thread); final Environment env = new Environment(); final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; - LispObject result = NIL; + LispObject result = NIL; try { thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package()); while (true) { @@ -527,10 +602,10 @@ thread.lastSpecialBinding = lastSpecialBinding; } return result; - //There's no point in using here the returnLastResult flag like in - //loadStream(): this function is only called from init-fasl, which is - //only called from load, which already has its own policy for choosing - //whether to return T or the last value. + //There's no point in using here the returnLastResult flag like in + //loadStream(): this function is only called from init-fasl, which is + //only called from load, which already has its own policy for choosing + //whether to return T or the last value. } // Returns extension including leading '.' @@ -600,10 +675,10 @@ { @Override public LispObject execute(LispObject filespec, LispObject verbose, - LispObject print, LispObject ifDoesNotExist) - throws ConditionThrowable { - return load(filespec, verbose, print, ifDoesNotExist, NIL); - } + LispObject print, LispObject ifDoesNotExist) + throws ConditionThrowable { + return load(filespec, verbose, print, ifDoesNotExist, NIL); + } }; // ### %load-returning-last-result filespec verbose print if-does-not-exist => object @@ -613,49 +688,49 @@ { @Override public LispObject execute(LispObject filespec, LispObject verbose, - LispObject print, LispObject ifDoesNotExist) - throws ConditionThrowable { - return load(filespec, verbose, print, ifDoesNotExist, T); - } + LispObject print, LispObject ifDoesNotExist) + throws ConditionThrowable { + return load(filespec, verbose, print, ifDoesNotExist, T); + } }; private static final LispObject load(LispObject filespec, - LispObject verbose, - LispObject print, - LispObject ifDoesNotExist, - LispObject returnLastResult) - throws ConditionThrowable { - if (filespec instanceof Stream) { - if (((Stream)filespec).isOpen()) { - LispObject pathname; - if (filespec instanceof FileStream) - pathname = ((FileStream)filespec).getPathname(); - else - pathname = NIL; - String truename; - if (pathname instanceof Pathname) - truename = ((Pathname)pathname).getNamestring(); - else - truename = null; - return loadFileFromStream(pathname, - truename, - (Stream) filespec, - verbose != NIL, - print != NIL, - false, - returnLastResult != NIL); - } - // If stream is closed, fall through... - } - Pathname pathname = coerceToPathname(filespec); - if (pathname instanceof LogicalPathname) - pathname = LogicalPathname.translateLogicalPathname((LogicalPathname)pathname); - return load(pathname, - pathname.getNamestring(), - verbose != NIL, - print != NIL, - ifDoesNotExist != NIL, - returnLastResult != NIL); + LispObject verbose, + LispObject print, + LispObject ifDoesNotExist, + LispObject returnLastResult) + throws ConditionThrowable { + if (filespec instanceof Stream) { + if (((Stream)filespec).isOpen()) { + LispObject pathname; + if (filespec instanceof FileStream) + pathname = ((FileStream)filespec).getPathname(); + else + pathname = NIL; + String truename; + if (pathname instanceof Pathname) + truename = ((Pathname)pathname).getNamestring(); + else + truename = null; + return loadFileFromStream(pathname, + truename, + (Stream) filespec, + verbose != NIL, + print != NIL, + false, + returnLastResult != NIL); + } + // If stream is closed, fall through... + } + Pathname pathname = coerceToPathname(filespec); + if (pathname instanceof LogicalPathname) + pathname = LogicalPathname.translateLogicalPathname((LogicalPathname)pathname); + return load(pathname, + pathname.getNamestring(), + verbose != NIL, + print != NIL, + ifDoesNotExist != NIL, + returnLastResult != NIL); } // ### load-system-file Modified: trunk/abcl/src/org/armedbear/lisp/Utilities.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Utilities.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Utilities.java Wed Sep 9 06:26:15 2009 @@ -33,8 +33,14 @@ package org.armedbear.lisp; +import java.io.ByteArrayInputStream; +import java.io.ByteArrayOutputStream; import java.io.File; import java.io.IOException; +import java.io.InputStream; +import java.util.zip.ZipEntry; +import java.util.zip.ZipFile; +import java.util.zip.ZipInputStream; public final class Utilities extends Lisp { @@ -115,4 +121,60 @@ return null; } } + + public static byte[] getZippedZipEntryAsByteArray(ZipFile zipfile, + String entryName, + String subEntryName) + throws ConditionThrowable + { + ZipEntry entry = zipfile.getEntry(entryName); + + ZipInputStream stream = null; + try { + stream = new ZipInputStream(zipfile.getInputStream(entry)); + } + catch (IOException e) { + Lisp.error(new FileError("Failed to open '" + entryName + "' in zipfile '" + + zipfile + "': " + e.getMessage())); + } + // XXX Cache the zipEntries somehow + do { + try { + entry = stream.getNextEntry(); + } catch (IOException e){ + Lisp.error(new FileError("Failed to seek for '" + subEntryName + + "' in '" + + zipfile.getName() + ":" + entryName + ".:" + + e.getMessage())); + } + } while (!entry.getName().equals(subEntryName)); + + ByteArrayOutputStream buffer = new ByteArrayOutputStream(); + int count; + byte buf[] = new byte[1024]; + try { + while ((count = stream.read(buf, 0, buf.length)) != -1) { + buffer.write(buf, 0, count); + } + } catch (java.io.IOException e) { + Lisp.error(new FileError("Failed to read compressed '" + + subEntryName + + "' in '" + + zipfile.getName() + ":" + entryName + ":" + + e.getMessage())); + } + return buffer.toByteArray(); + } + + public static InputStream getZippedZipEntryAsInputStream(ZipFile zipfile, + String entryName, + String subEntryName) + throws ConditionThrowable + { + return + new ByteArrayInputStream(Utilities + .getZippedZipEntryAsByteArray(zipfile, entryName, + subEntryName)); + } } + Added: trunk/abcl/test/lisp/abcl/bar.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/bar.lisp Wed Sep 9 06:26:15 2009 @@ -0,0 +1,11 @@ +(defun bar () + (labels + ((output () (format t "Some BAR"))) + (output))) + +(defvar *bar* t) + +(defun baz () + (format t "Some BAZ")) + + Added: trunk/abcl/test/lisp/abcl/eek.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/eek.lisp Wed Sep 9 06:26:15 2009 @@ -0,0 +1,9 @@ +(defun eek () + (format t "Another EEK.")) + +(defun ook () + (let ((*load-verbose* t)) + (load (merge-pathnames #p"bar" *load-truename*)))) + +(defun aak () + (format t "*LOAD-TRUENAME* is '~A'" *load-truename*)) Added: trunk/abcl/test/lisp/abcl/foo.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/foo.lisp Wed Sep 9 06:26:15 2009 @@ -0,0 +1,19 @@ +#| + +Compile with + + (let ((sys::*compile-file-zip* t)) + (compile-file "foo.lisp" :output-file "foo.jar")) + +Load with + + (load "jar:file:foo.jar!/foo") + +|# + +(defun foo () + (labels ((output () + (format t "FOO here."))) + (output))) + + Added: trunk/abcl/test/lisp/abcl/load.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/load.lisp Wed Sep 9 06:26:15 2009 @@ -0,0 +1,60 @@ +(in-package #:abcl.test.lisp) + +#-:unix (error "Load test setup currently needs UNIX shell script support.") + +(defun load-init () + (let* ((*default-pathname-defaults* *this-directory*) + (asdf::*verbose-out* *standard-output*) + (package-command (format nil "sh ~A" (merge-pathnames "package-load.sh")))) + (compile-file "foo.lisp") + (compile-file "bar.lisp") + (compile-file "eek.lisp") + (asdf:run-shell-command package-command))) + +(load-init) + +(deftest load.1 + (let ((*default-pathname-defaults* *this-directory*)) + (load "foo")) + t) + +(deftest load.2 + (let ((*default-pathname-defaults* *this-directory*)) + (load "foo.lisp")) + t) + +(deftest load.3 + (let ((*default-pathname-defaults* *this-directory*)) + (load "foo.abcl")) + t) + +(deftest load.4 + (let ((*default-pathname-defaults* *this-directory*)) + (load "jar:file:baz.jar!/foo")) + t) + +(deftest load.6 + (let ((*default-pathname-defaults* *this-directory*)) + (load "jar:file:baz.jar!/bar")) + t) + +(deftest load.7 + (let ((*default-pathname-defaults* *this-directory*)) + (load "jar:file:baz.jar!/bar.abcl")) + t) + +(deftest load.8 + (let ((*default-pathname-defaults* *this-directory*)) + (load "jar:file:baz.jar!/eek")) + t) + +(deftest load.9 + (let ((*default-pathname-defaults* *this-directory*)) + (load "jar:file:baz.jar!/eek.lisp")) + t) + + + + + + Added: trunk/abcl/test/lisp/abcl/package-load.sh ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/package-load.sh Wed Sep 9 06:26:15 2009 @@ -0,0 +1,18 @@ +#!/bin/sh +srcdir=$PWD +tmpdir=/tmp/$$ + +mkdir $tmpdir + +cd $tmpdir + +unzip $srcdir/foo.abcl + +cp $srcdir/bar.abcl . + +cp $srcdir/eek.lisp . + +jar cfv $srcdir/baz.jar * + +rm -rf $tmpdir + Modified: trunk/abcl/test/lisp/abcl/package.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/package.lisp (original) +++ trunk/abcl/test/lisp/abcl/package.lisp Wed Sep 9 06:26:15 2009 @@ -1,5 +1,6 @@ (defpackage #:abcl.test.lisp (:use #:cl #:abcl-rt) + (:nicknames "ABCL-TEST") (:export #:run)) (in-package #:abcl.test.lisp) From vvoutilainen at common-lisp.net Thu Sep 10 20:56:05 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Thu, 10 Sep 2009 16:56:05 -0400 Subject: [armedbear-cvs] r12142 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Thu Sep 10 16:56:03 2009 New Revision: 12142 Log: Fix defect #62 - the argument check was still too strict, it needs to skip initargs if &ALLOW-OTHER-KEYS is found in method lambda lists. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Thu Sep 10 16:56:03 2009 @@ -1995,7 +1995,9 @@ (when (symbolp initarg) (dolist (method methods nil) (let ((valid-initargs (method-lambda-list method))) - (when (find (symbol-value initarg) valid-initargs :test #'string=) + (when (or + (find "&ALLOW-OTHER-KEYS" valid-initargs :test #'string=) + (find (symbol-value initarg) valid-initargs :test #'string=)) (return t)))))) (defun valid-initarg-p (initarg slots) From vvoutilainen at common-lisp.net Thu Sep 10 21:30:04 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Thu, 10 Sep 2009 17:30:04 -0400 Subject: [armedbear-cvs] r12143 - branches/0.16.x/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Thu Sep 10 17:30:02 2009 New Revision: 12143 Log: Backport the asdf fix from trunk. Modified: branches/0.16.x/abcl/src/org/armedbear/lisp/clos.lisp Modified: branches/0.16.x/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- branches/0.16.x/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ branches/0.16.x/abcl/src/org/armedbear/lisp/clos.lisp Thu Sep 10 17:30:02 2009 @@ -1995,7 +1995,9 @@ (when (symbolp initarg) (dolist (method methods nil) (let ((valid-initargs (method-lambda-list method))) - (when (find (symbol-value initarg) valid-initargs :test #'string=) + (when (or + (find "&ALLOW-OTHER-KEYS" valid-initargs :test #'string=) + (find (symbol-value initarg) valid-initargs :test #'string=)) (return t)))))) (defun valid-initarg-p (initarg slots) From ehuelsmann at common-lisp.net Mon Sep 14 14:46:19 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 14 Sep 2009 10:46:19 -0400 Subject: [armedbear-cvs] r12144 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Sep 14 10:46:15 2009 New Revision: 12144 Log: Add newly created blocks to the BLOCKS slot of the current compiland again. This used to happen correctly when we were only creating BLOCK-NODEs. This commit restores the behaviour. Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Mon Sep 14 10:46:15 2009 @@ -364,6 +364,8 @@ (defstruct node form (compiland *current-compiland*)) +;; No need for a special constructor: nobody instantiates +;; nodes directly ;; control-transferring blocks: TAGBODY, CATCH, to do: BLOCK @@ -373,17 +375,32 @@ ;; Non-nil if and only if the block doesn't modify the environment needs-environment-restoration ) +;; No need for a special constructor: nobody instantiates +;; control-transferring-nodes directly (defstruct (tagbody-node (:conc-name tagbody-) - (:include control-transferring-node)) + (:include control-transferring-node) + (:constructor %make-tagbody-node ())) ;; True if a tag in this tagbody is the target of a non-local GO. non-local-go-p tags) +(defknown make-tagbody-node () t) +(defun make-tagbody-node () + (let ((block (%make-tagbody-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defstruct (catch-node (:conc-name catch-) - (:include control-transferring-node)) - ;; fixme? tag gotten from the catch-form + (:include control-transferring-node) + (:constructor %make-catch-node ())) + ;; The catch tag-form is evaluated, meaning we + ;; have no predefined value to store here ) +(defknown make-catch-node () t) +(defun make-catch-node () + (let ((block (%make-catch-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defstruct (block-node (:conc-name block-) (:include control-transferring-node) @@ -393,53 +410,110 @@ target ;; True if there is a non-local RETURN from this block. non-local-return-p) +(defknown make-block-node (t) t) +(defun make-block-node (name) + (let ((block (%make-block-node name))) + (push block (compiland-blocks *current-compiland*)) + block)) ;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY +;; +;; Binding blocks can carry references to local (optionally special) variable bindings, +;; contain free special bindings or both (defstruct (binding-node (:include node)) - ;; If non-nil, register containing saved dynamic environment for this block. + ;; number of the register of the saved dynamic env, or NIL if none environment-register - ;; Not used for LOCALLY, FLET, LABELS + ;; Not used for LOCALLY and FLET; LABELS uses vars to store its functions vars free-specials) +;; nobody instantiates any binding nodes directly, so there's no reason +;; to create a constructor with the approprate administration code (defstruct (let/let*-node (:conc-name let-) - (:include binding-node))) + (:include binding-node) + (:constructor %make-let/let*-node ()))) +(defknown make-let/let*-node () t) +(defun make-let/let*-node () + (let ((block (%make-let/let*-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defstruct (flet-node (:conc-name flet-) (:include binding-node))) +(defknown make-let/let*-node () t) +(defun make-let/let*-node () + (let ((block (%make-let/let*-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defstruct (labels-node (:conc-name labels-) - (:include binding-node))) + (:include binding-node) + (:constructor %make-labels-node ()))) +(defknown make-labels-node () t) +(defun make-labels-node () + (let ((block (%make-labels-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defstruct (m-v-b-node (:conc-name m-v-b-) - (:include binding-node))) + (:include binding-node) + (:constructor %make-m-v-b-node ()))) +(defknown make-m-v-b-node () t) +(defun make-m-v-b-node () + (let ((block (%make-m-v-b-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defstruct (progv-node (:conc-name progv-) - (:include binding-node))) + (:include binding-node) + (:constructor %make-progv-node ()))) +(defknown make-progv-node () t) +(defun make-progv-node () + (let ((block (%make-progv-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defstruct (locally-node (:conc-name locally-) - (:include binding-node))) + (:include binding-node) + (:constructor %make-locally-node ()))) +(defknown make-locally-node () t) +(defun make-locally-node () + (let ((block (%make-locally-node))) + (push block (compiland-blocks *current-compiland*)) + block)) ;; blocks requiring non-local exits: UNWIND-PROTECT, SYS:SYNCHRONIZED-ON -(defstruct (protected-node (:include node))) +(defstruct (protected-node (:include node) + (:constructor %make-protected-node ()))) +(defknown make-protected-node () t) +(defun make-protected-node () + (let ((block (%make-protected-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defstruct (unwind-protect-node (:conc-name unwind-protect-) - (:include protected-node))) + (:include protected-node) + (:constructor %make-unwind-protect-node ()))) +(defknown make-unwind-protect-node () t) +(defun make-unwind-protect-node () + (let ((block (%make-unwind-protect-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defstruct (synchronized-node (:conc-name synchronized-) - (:include protected-node))) + (:include protected-node) + (:constructor %make-synchronized-node ()))) +(defknown make-synchronized-node () t) +(defun make-synchronized-node () + (let ((block (%make-synchronized-node))) + (push block (compiland-blocks *current-compiland*)) + block)) (defvar *blocks* ()) -(defknown make-block-node (t) t) -(defun make-block-node (name) - (let ((block (%make-block-node name))) - (push block (compiland-blocks *current-compiland*)) - block)) - (defun find-block (name) (dolist (block *blocks*) (when (and (block-node-p block) From vvoutilainen at common-lisp.net Mon Sep 14 15:26:05 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Mon, 14 Sep 2009 11:26:05 -0400 Subject: [armedbear-cvs] r12145 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Mon Sep 14 11:26:02 2009 New Revision: 12145 Log: Don't traverse the lambda list twice when checking method args. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Sep 14 11:26:02 2009 @@ -1995,9 +1995,12 @@ (when (symbolp initarg) (dolist (method methods nil) (let ((valid-initargs (method-lambda-list method))) - (when (or - (find "&ALLOW-OTHER-KEYS" valid-initargs :test #'string=) - (find (symbol-value initarg) valid-initargs :test #'string=)) + (when (find (symbol-value initarg) valid-initargs + :test #'(lambda (a b) + (or + (string= a b) + (string= b "&ALLOW-OTHER-KEYS")))) + (return t)))))) (defun valid-initarg-p (initarg slots) From mevenson at common-lisp.net Thu Sep 17 13:42:04 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 17 Sep 2009 09:42:04 -0400 Subject: [armedbear-cvs] r12146 - in trunk/abcl/nbproject: . configs private private/configs Message-ID: Author: mevenson Date: Thu Sep 17 09:42:01 2009 New Revision: 12146 Log: NetBeans: remove 'J' configuration, add 'slime' for debugging SLIME. To use the 'slime' configuration, you need to have the directory 'swank.asd' file appear in ASDF:*CENTRAL-REGISTRY*. Then after running the configuration, you can connect to the SLIME from Emacs by invoking "M-x slime-connect". Added: trunk/abcl/nbproject/configs/slime.properties trunk/abcl/nbproject/private/ trunk/abcl/nbproject/private/configs/ trunk/abcl/nbproject/private/configs/slime.properties Removed: trunk/abcl/nbproject/configs/J.properties Modified: trunk/abcl/nbproject/build-impl.xml trunk/abcl/nbproject/genfiles.properties Modified: trunk/abcl/nbproject/build-impl.xml ============================================================================== --- trunk/abcl/nbproject/build-impl.xml (original) +++ trunk/abcl/nbproject/build-impl.xml Thu Sep 17 09:42:01 2009 @@ -152,7 +152,7 @@ - + Added: trunk/abcl/nbproject/configs/slime.properties ============================================================================== Modified: trunk/abcl/nbproject/genfiles.properties ============================================================================== --- trunk/abcl/nbproject/genfiles.properties (original) +++ trunk/abcl/nbproject/genfiles.properties Thu Sep 17 09:42:01 2009 @@ -4,8 +4,8 @@ # This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml. # Do not edit this file. You may delete it but then the IDE will never regenerate such files for you. nbproject/build-impl.xml.data.CRC32=742204ce -nbproject/build-impl.xml.script.CRC32=b94c76f8 -nbproject/build-impl.xml.stylesheet.CRC32=e55b27f5 +nbproject/build-impl.xml.script.CRC32=b7bf05a5 +nbproject/build-impl.xml.stylesheet.CRC32=65b8de21 nbproject/profiler-build-impl.xml.data.CRC32=71623fcd nbproject/profiler-build-impl.xml.script.CRC32=abda56ed nbproject/profiler-build-impl.xml.stylesheet.CRC32=42cb6bcf Added: trunk/abcl/nbproject/private/configs/slime.properties ============================================================================== --- (empty file) +++ trunk/abcl/nbproject/private/configs/slime.properties Thu Sep 17 09:42:01 2009 @@ -0,0 +1 @@ +application.args=--eval "(require (quote asdf))" --eval "(asdf:operate (quote asdf:load-op) :swank)" --eval "(swank:create-server)" From vvoutilainen at common-lisp.net Thu Sep 17 17:08:35 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Thu, 17 Sep 2009 13:08:35 -0400 Subject: [armedbear-cvs] r12147 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Thu Sep 17 13:08:32 2009 New Revision: 12147 Log: Fix PRINT-LENGTH.INIT.1. Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/top-level.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/top-level.lisp Thu Sep 17 13:08:32 2009 @@ -406,13 +406,12 @@ (defparameter *repl-read-form-fun* #'repl-read-form-fun) (defun repl (&optional (in *standard-input*) (out *standard-output*)) - (let* ((*print-length* 10)) (loop (let* ((form (funcall *repl-read-form-fun* in out)) (results (multiple-value-list (sys:interactive-eval form)))) (dolist (result results) (fresh-line out) - (prin1 result out)))))) + (prin1 result out))))) (defun top-level-loop () (fresh-line) From vvoutilainen at common-lisp.net Thu Sep 17 17:19:55 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Thu, 17 Sep 2009 13:19:55 -0400 Subject: [armedbear-cvs] r12148 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Thu Sep 17 13:19:55 2009 New Revision: 12148 Log: Fix FORMAT.C.4A and FORMATTER.C.4A. This patch as well as the previous fix for PRINT-LENGTH.INIT.1 were contributed by Douglas R. Miles. Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispCharacter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Thu Sep 17 13:19:55 2009 @@ -32,6 +32,8 @@ */ package org.armedbear.lisp; +import java.util.HashMap; +import java.util.Map; public final class LispCharacter extends LispObject { @@ -44,7 +46,7 @@ } public final char value; - + private String name; public static LispCharacter getInstance(char c) { try @@ -256,8 +258,11 @@ case 127: sb.append("Rubout"); break; - default: - sb.append(value); + default: + if (name!=null) + sb.append(name); + else + sb.append(value); break; } } @@ -541,6 +546,8 @@ public static final int nameToChar(String s) { String lower = s.toLowerCase(); + LispCharacter lc = namedToChar.get(lower); + if (lc!=null) return lc.value; if (lower.equals("null")) return 0; if (lower.equals("bell")) @@ -605,7 +612,8 @@ case 127: return "Rubout"; } - return null; + if (c<0 || c>255) return null; + return constants[c].name; } // ### char-name @@ -627,6 +635,39 @@ return Character.toUpperCase(c); } + static int maxNamedChar = 0; + static Map namedToChar = new HashMap(); + + static void setCharNames(int i, String[] string) { + int settingChar = i; + int index = 0; + int stringLen = string.length; + while(stringLen-->0) { + setCharName(settingChar,string[index]); + index++; + settingChar++; + } + if (maxNamedChar=CHAR_MAX) return; + LispCharacter c = constants[settingChar]; + c.name = string; + namedToChar.put(string.toLowerCase(), c); + } + + static { + new CharNameMaker0(); + } + + static class CharNameMaker0{ + { + setCharNames(0,new String[]{"Null", "Soh", "Stx", "Etx", "Eot", "Enq", "Ack", "Bell", "Backspace", "Tab", "Newline", "Vt", "Page", "Return", "So", "Si", "Dle", "Dc1", "Dc2", "Dc3", "Dc4", "Nak", "Syn", "Etb", "Can", "Em", "Sub", "Escape", "Fs", "Gs", "Rs", "Us"}); + setCharNames(128,new String[]{"U0080", "U0081", "U0082", "U0083", "U0084", "U0085", "U0086", "U0087", "U0088", "U0089", "U008a", "U008b", "U008c", "U008d", "U008e", "U008f", "U0090", "U0091", "U0092", "U0093", "U0094", "U0095", "U0096", "U0097", "U0098", "U0099", "U009a", "U009b", "U009c", "U009d", "U009e", "U009f"}); + } + } + private static final char[] UPPER_CASE_CHARS = new char[128]; static From mevenson at common-lisp.net Fri Sep 18 06:22:44 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 18 Sep 2009 02:22:44 -0400 Subject: [armedbear-cvs] r12149 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Sep 18 02:22:41 2009 New Revision: 12149 Log: Guard against null pointers in LispStackFrame (Tobias Rittweiler). Explicity create an UnavailableArgument object to fill LispStackFrame objects which have null args members. Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Fri Sep 18 02:22:41 2009 @@ -632,24 +632,30 @@ return toString(); } - public String unreadableString(String s) + public String unreadableString(String s) { + return unreadableString(s, true); + } + public String unreadableString(Symbol sym) throws ConditionThrowable { + return unreadableString(sym, true); + } + + public String unreadableString(String s, boolean identity) { FastStringBuffer sb = new FastStringBuffer("#<"); sb.append(s); - sb.append(" {"); - sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); - sb.append("}>"); + if (identity) { + sb.append(" {"); + sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); + sb.append("}"); + } + sb.append(">"); return sb.toString(); } - public String unreadableString(Symbol symbol) throws ConditionThrowable + public String unreadableString(Symbol symbol, boolean identity) + throws ConditionThrowable { - FastStringBuffer sb = new FastStringBuffer("#<"); - sb.append(symbol.writeToString()); - sb.append(" {"); - sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); - sb.append("}>"); - return sb.toString(); + return unreadableString(symbol.writeToString(), identity); } // Special operator Modified: trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Fri Sep 18 02:22:41 2009 @@ -42,6 +42,17 @@ private final LispObject third; private final LispObject[] args; + private final class UnavailableArgument extends LispObject + { + public UnavailableArgument () { } + @Override + public String writeToString() { + return unreadableString("unavailable arg", false); + } + } + + private final LispObject UNAVAILABLE_ARG = new UnavailableArgument(); + public LispStackFrame(LispObject operator) { this.operator = operator; @@ -108,8 +119,8 @@ try { result = unreadableString(LISP_STACK_FRAME + " " + toLispString().getStringValue()); - } catch (ConditionThrowable t) { - Debug.trace("Implementation error: "); + } catch (Throwable t) { + Debug.trace("Serious printing error: "); Debug.trace(t); result = unreadableString(LISP_STACK_FRAME); } @@ -145,7 +156,15 @@ LispObject result = Lisp.NIL; if (args != null) { for (int i = 0; i < args.length; i++) - result = result.push(args[i]); + // `args' come here from LispThread.execute. I don't know + // how it comes that some callers pass NULL ptrs around but + // we better do not create conses with their CAR being NULL; + // it'll horribly break printing such a cons; and probably + // other bad things may happen, too. --TCR, 2009-09-17. + if (args[i] == null) + result = result.push(UNAVAILABLE_ARG); + else + result = result.push(args[i]); } else { do { if (first != null) @@ -168,7 +187,15 @@ public SimpleString toLispString() throws ConditionThrowable { - return new SimpleString(toLispList().writeToString()); + String result; + try { + result = this.toLispList().writeToString(); + } catch (Throwable t) { + Debug.trace("Serious printing error: "); + Debug.trace(t); + result = unreadableString("LISP-STACK-FRAME"); + } + return new SimpleString(result); } public LispObject getOperator() { From mevenson at common-lisp.net Fri Sep 18 06:31:07 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 18 Sep 2009 02:31:07 -0400 Subject: [armedbear-cvs] r12150 - in branches/0.16.x/abcl: . src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Sep 18 02:31:06 2009 New Revision: 12150 Log: Backport [svn 12149] guard against null LispStackFrames. Updated CHANGES to list bugs for unreleased 0.16.1. Modified: branches/0.16.x/abcl/CHANGES branches/0.16.x/abcl/src/org/armedbear/lisp/LispObject.java branches/0.16.x/abcl/src/org/armedbear/lisp/LispStackFrame.java Modified: branches/0.16.x/abcl/CHANGES ============================================================================== --- branches/0.16.x/abcl/CHANGES (original) +++ branches/0.16.x/abcl/CHANGES Fri Sep 18 02:31:06 2009 @@ -1,5 +1,14 @@ +Version 0.16.1 +svn://common-lisp.net/project/armedbear/svn/branches/0.16.x/abcl +(Unreleased) + +Bugs fixed: + + * More careful checking for null args in LispStackFrame + * Honor appearance of &allow-other-keys in CLOS MAKE-INSTANCE + Version 0.16.0 -(unreleased) +(06 Sep, 2009) Summary of changes: * Fixed generated wrapper for path names with spaces (Windows) Modified: branches/0.16.x/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- branches/0.16.x/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ branches/0.16.x/abcl/src/org/armedbear/lisp/LispObject.java Fri Sep 18 02:31:06 2009 @@ -632,24 +632,30 @@ return toString(); } - public String unreadableString(String s) + public String unreadableString(String s) { + return unreadableString(s, true); + } + public String unreadableString(Symbol sym) throws ConditionThrowable { + return unreadableString(sym, true); + } + + public String unreadableString(String s, boolean identity) { FastStringBuffer sb = new FastStringBuffer("#<"); sb.append(s); - sb.append(" {"); - sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); - sb.append("}>"); + if (identity) { + sb.append(" {"); + sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); + sb.append("}"); + } + sb.append(">"); return sb.toString(); } - public String unreadableString(Symbol symbol) throws ConditionThrowable + public String unreadableString(Symbol symbol, boolean identity) + throws ConditionThrowable { - FastStringBuffer sb = new FastStringBuffer("#<"); - sb.append(symbol.writeToString()); - sb.append(" {"); - sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); - sb.append("}>"); - return sb.toString(); + return unreadableString(symbol.writeToString(), identity); } // Special operator Modified: branches/0.16.x/abcl/src/org/armedbear/lisp/LispStackFrame.java ============================================================================== --- branches/0.16.x/abcl/src/org/armedbear/lisp/LispStackFrame.java (original) +++ branches/0.16.x/abcl/src/org/armedbear/lisp/LispStackFrame.java Fri Sep 18 02:31:06 2009 @@ -42,6 +42,17 @@ private final LispObject third; private final LispObject[] args; + private final class UnavailableArgument extends LispObject + { + public UnavailableArgument () { } + @Override + public String writeToString() { + return unreadableString("unavailable arg", false); + } + } + + private final LispObject UNAVAILABLE_ARG = new UnavailableArgument(); + public LispStackFrame(LispObject operator) { this.operator = operator; @@ -108,8 +119,8 @@ try { result = unreadableString(LISP_STACK_FRAME + " " + toLispString().getStringValue()); - } catch (ConditionThrowable t) { - Debug.trace("Implementation error: "); + } catch (Throwable t) { + Debug.trace("Serious printing error: "); Debug.trace(t); result = unreadableString(LISP_STACK_FRAME); } @@ -144,8 +155,16 @@ { LispObject result = Lisp.NIL; if (args != null) { - for (int i = 0; i < args.length; i++) - result = result.push(args[i]); + for (int i = 0; i < args.length; i++) + // `args' come here from LispThread.execute. I don't know + // how it comes that some callers pass NULL ptrs around but + // we better do not create conses with their CAR being NULL; + // it'll horribly break printing such a cons; and probably + // other bad things may happen, too. --TCR, 2009-09-17. + if (args[i] == null) + result = result.push(UNAVAILABLE_ARG); + else + result = result.push(args[i]); } else { do { if (first != null) @@ -168,7 +187,15 @@ public SimpleString toLispString() throws ConditionThrowable { - return new SimpleString(toLispList().writeToString()); + String result; + try { + result = this.toLispList().writeToString(); + } catch (Throwable t) { + Debug.trace("Serious printing error: "); + Debug.trace(t); + result = unreadableString("LISP-STACK-FRAME"); + } + return new SimpleString(result); } public LispObject getOperator() { From mevenson at common-lisp.net Fri Sep 18 06:33:54 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 18 Sep 2009 02:33:54 -0400 Subject: [armedbear-cvs] r12151 - trunk/abcl Message-ID: Author: mevenson Date: Fri Sep 18 02:33:53 2009 New Revision: 12151 Log: Start recording CHANGES again. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Fri Sep 18 02:33:53 2009 @@ -1,6 +1,18 @@ -Version 0.16.0 +Version 0.17.0 (unreleased) +Features + * Support for loading FASLs from JAR files. + +Bugs. + + * More careful checking for null args in LispStackFrame + * Honor appearance of &allow-other-keys in CLOS MAKE-INSTANCE + +Version 0.16.0 +(06 SEP 2009) +svn://common-lisp.net/project/armedbear/svn/tags/0.16.0/abcl + Summary of changes: * Fixed generated wrapper for path names with spaces (Windows) * Fixed ticket #58: Inspection of Java objects in Lisp code From mevenson at common-lisp.net Fri Sep 18 06:57:05 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 18 Sep 2009 02:57:05 -0400 Subject: [armedbear-cvs] r12152 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Sep 18 02:57:04 2009 New Revision: 12152 Log: Native EOL style for source code. Modified: trunk/abcl/src/org/armedbear/lisp/JavaClass.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/JavaClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaClass.java Fri Sep 18 02:57:04 2009 @@ -1,147 +1,147 @@ -/* - * BuiltInClass.java - * - * Copyright (C) 2003-2007 Peter Graves - * $Id: BuiltInClass.java 11297 2008-08-31 13:26:45Z ehuelsmann $ - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - */ - -package org.armedbear.lisp; - -import java.util.HashMap; -import java.util.HashSet; -import java.util.LinkedList; -import java.util.Map; -import java.util.Queue; -import java.util.Set; -import java.util.Stack; - -public class JavaClass extends LispClass { - - private Class javaClass; - //There is no point for this Map to be weak since values keep a reference to the corresponding - //key (the Java class). This should not be a problem since Java classes are limited in number - - //if they grew indefinitely, the JVM itself would crash. - private static final Map, JavaClass> cache = new HashMap, JavaClass>(); - - private JavaClass(Class javaClass) { - this.javaClass = javaClass; - setDirectSuperclass(BuiltInClass.JAVA_OBJECT); - } - - private void initCPL() { - LispObject cpl = Lisp.NIL; - try { - cpl = cpl.push(BuiltInClass.CLASS_T); - cpl = cpl.push(BuiltInClass.JAVA_OBJECT); - Set> alreadySeen = new HashSet>(); - Stack stack = new Stack(); - Class theClass = javaClass; - boolean stop = false; - while(!stop && theClass != null) { - stop = addClass(alreadySeen, stack, theClass); - for(Class c : theClass.getInterfaces()) { - stop = addClass(alreadySeen, stack, c) && stop; //watch out for short-circuiting! - } - theClass = theClass.getSuperclass(); - } - while(!stack.isEmpty()) { - cpl = cpl.push(stack.pop()); - } - } catch (ConditionThrowable e) { - throw new Error("Cannot push class in class precedence list", e); - } - setCPL(cpl); - } - - private static boolean addClass(Set> alreadySeen, Stack stack, Class theClass) { - if(!alreadySeen.contains(theClass)) { - alreadySeen.add(theClass); - stack.push(findJavaClass(theClass)); - return false; - } - return true; - } - - public LispObject typeOf() { - return Symbol.JAVA_CLASS; - } - - public LispObject classOf() { - return StandardClass.JAVA_CLASS; - } - - public LispObject typep(LispObject type) throws ConditionThrowable { - if (type == Symbol.JAVA_CLASS) - return T; - if (type == StandardClass.JAVA_CLASS) - return T; - return super.typep(type); - } - - public LispObject getDescription() throws ConditionThrowable { - return new SimpleString(writeToString()); - } - - public String writeToString() throws ConditionThrowable { - FastStringBuffer sb = new FastStringBuffer("#'); - return sb.toString(); - } - - public static JavaClass findJavaClass(Class javaClass) { - synchronized (cache) { - JavaClass c = cache.get(javaClass); - if (c == null) { - c = new JavaClass(javaClass); - cache.put(javaClass, c); - c.initCPL(); - } - return c; - } - } - - public Class getJavaClass() { - return javaClass; - } - - public boolean subclassp(LispObject obj) throws ConditionThrowable { - if(obj == BuiltInClass.CLASS_T) { - return true; - } - if(obj == BuiltInClass.JAVA_OBJECT) { - return true; - } - if(obj instanceof JavaClass) { - return ((JavaClass) obj).getJavaClass().isAssignableFrom(javaClass); - } - return false; - } - - private static final Primitive _FIND_JAVA_CLASS = new Primitive( - "%find-java-class", PACKAGE_JAVA, false, "string") { - public LispObject execute(LispObject arg) throws ConditionThrowable { - try { - return findJavaClass(Class.forName((String) arg.getStringValue())); - } catch (ClassNotFoundException e) { - throw new ConditionThrowable("Cannot find Java class " + arg.getStringValue()); - } - } - - }; - -} +/* + * BuiltInClass.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: BuiltInClass.java 11297 2008-08-31 13:26:45Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp; + +import java.util.HashMap; +import java.util.HashSet; +import java.util.LinkedList; +import java.util.Map; +import java.util.Queue; +import java.util.Set; +import java.util.Stack; + +public class JavaClass extends LispClass { + + private Class javaClass; + //There is no point for this Map to be weak since values keep a reference to the corresponding + //key (the Java class). This should not be a problem since Java classes are limited in number - + //if they grew indefinitely, the JVM itself would crash. + private static final Map, JavaClass> cache = new HashMap, JavaClass>(); + + private JavaClass(Class javaClass) { + this.javaClass = javaClass; + setDirectSuperclass(BuiltInClass.JAVA_OBJECT); + } + + private void initCPL() { + LispObject cpl = Lisp.NIL; + try { + cpl = cpl.push(BuiltInClass.CLASS_T); + cpl = cpl.push(BuiltInClass.JAVA_OBJECT); + Set> alreadySeen = new HashSet>(); + Stack stack = new Stack(); + Class theClass = javaClass; + boolean stop = false; + while(!stop && theClass != null) { + stop = addClass(alreadySeen, stack, theClass); + for(Class c : theClass.getInterfaces()) { + stop = addClass(alreadySeen, stack, c) && stop; //watch out for short-circuiting! + } + theClass = theClass.getSuperclass(); + } + while(!stack.isEmpty()) { + cpl = cpl.push(stack.pop()); + } + } catch (ConditionThrowable e) { + throw new Error("Cannot push class in class precedence list", e); + } + setCPL(cpl); + } + + private static boolean addClass(Set> alreadySeen, Stack stack, Class theClass) { + if(!alreadySeen.contains(theClass)) { + alreadySeen.add(theClass); + stack.push(findJavaClass(theClass)); + return false; + } + return true; + } + + public LispObject typeOf() { + return Symbol.JAVA_CLASS; + } + + public LispObject classOf() { + return StandardClass.JAVA_CLASS; + } + + public LispObject typep(LispObject type) throws ConditionThrowable { + if (type == Symbol.JAVA_CLASS) + return T; + if (type == StandardClass.JAVA_CLASS) + return T; + return super.typep(type); + } + + public LispObject getDescription() throws ConditionThrowable { + return new SimpleString(writeToString()); + } + + public String writeToString() throws ConditionThrowable { + FastStringBuffer sb = new FastStringBuffer("#'); + return sb.toString(); + } + + public static JavaClass findJavaClass(Class javaClass) { + synchronized (cache) { + JavaClass c = cache.get(javaClass); + if (c == null) { + c = new JavaClass(javaClass); + cache.put(javaClass, c); + c.initCPL(); + } + return c; + } + } + + public Class getJavaClass() { + return javaClass; + } + + public boolean subclassp(LispObject obj) throws ConditionThrowable { + if(obj == BuiltInClass.CLASS_T) { + return true; + } + if(obj == BuiltInClass.JAVA_OBJECT) { + return true; + } + if(obj instanceof JavaClass) { + return ((JavaClass) obj).getJavaClass().isAssignableFrom(javaClass); + } + return false; + } + + private static final Primitive _FIND_JAVA_CLASS = new Primitive( + "%find-java-class", PACKAGE_JAVA, false, "string") { + public LispObject execute(LispObject arg) throws ConditionThrowable { + try { + return findJavaClass(Class.forName((String) arg.getStringValue())); + } catch (ClassNotFoundException e) { + throw new ConditionThrowable("Cannot find Java class " + arg.getStringValue()); + } + } + + }; + +} From mevenson at common-lisp.net Fri Sep 18 13:43:46 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 18 Sep 2009 09:43:46 -0400 Subject: [armedbear-cvs] r12153 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Sep 18 09:43:42 2009 New Revision: 12153 Log: Tenative fix for #63: transform caught Go throwable to LispError. Normalized printStackTrace() calls through Debug.trace() interface. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Fri Sep 18 09:43:42 2009 @@ -123,7 +123,7 @@ } catch (Throwable t) { - t.printStackTrace(); + Debug.trace(t); } } @@ -277,7 +277,7 @@ } catch (Go go) { - throw go; + return error(go.getCondition()); } catch (Throw t) { @@ -1042,6 +1042,7 @@ } catch (Throwable t) { + Debug.trace(t); return null; } } @@ -2586,7 +2587,7 @@ } catch (ClassNotFoundException e) { - e.printStackTrace(); + Debug.trace(e); } } From ehuelsmann at common-lisp.net Fri Sep 18 20:40:47 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 18 Sep 2009 16:40:47 -0400 Subject: [armedbear-cvs] r12154 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Sep 18 16:40:44 2009 New Revision: 12154 Log: TAGBODY efficiency: only check those tags which are being used as "targets" for Go exceptions. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.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/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Sep 18 16:40:44 2009 @@ -426,14 +426,16 @@ (cond ((eq (tag-compiland tag) *current-compiland*) ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH? (if (enclosed-by-protected-block-p tag-block) - (setf (tagbody-non-local-go-p tag-block) t) + (setf (tagbody-non-local-go-p tag-block) t + (tag-used-non-locally tag) t) ;; non-local GO's ensure environment restoration ;; find out about this local GO (when (null (tagbody-needs-environment-restoration tag-block)) (setf (tagbody-needs-environment-restoration tag-block) (enclosed-by-environment-setting-block-p tag-block))))) (t - (setf (tagbody-non-local-go-p tag-block) t))))) + (setf (tagbody-non-local-go-p tag-block) t + (tag-used-non-locally tag) t))))) form) (defun validate-function-name (name) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Sep 18 16:40:44 2009 @@ -4502,8 +4502,9 @@ (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1. (astore tag-register) ;; Don't actually generate comparisons for tags - ;; to which there is no GO instruction - (dolist (tag (remove-if-not #'tag-used (tagbody-tags block))) + ;; to which there is no non-local GO instruction + (dolist (tag (remove-if-not #'tag-used-non-locally + (tagbody-tags block))) (let ((NEXT (gensym))) (aload tag-register) (emit 'getstatic *this-class* 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 Fri Sep 18 16:40:44 2009 @@ -588,7 +588,8 @@ ;; The associated TAGBODY block (compiland *current-compiland*) - used) + used + used-non-locally) (defknown find-tag (t) t) (defun find-tag (name) From mevenson at common-lisp.net Sun Sep 20 08:31:05 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 20 Sep 2009 04:31:05 -0400 Subject: [armedbear-cvs] r12155 - in branches/0.16.x/abcl: . src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Sep 20 04:31:01 2009 New Revision: 12155 Log: Backported changes for Fix #63: GO forms to non-existent TAGBODY labels would exit ABCL Modified: branches/0.16.x/abcl/CHANGES branches/0.16.x/abcl/src/org/armedbear/lisp/Lisp.java Modified: branches/0.16.x/abcl/CHANGES ============================================================================== --- branches/0.16.x/abcl/CHANGES (original) +++ branches/0.16.x/abcl/CHANGES Sun Sep 20 04:31:01 2009 @@ -6,8 +6,10 @@ * More careful checking for null args in LispStackFrame * Honor appearance of &allow-other-keys in CLOS MAKE-INSTANCE + * Fix #63: GO forms to non-existent TAGBODY labels would exit ABCL Version 0.16.0 +svn://common-lisp.net/project/armedbear/svn/tags/0.16.0/abcl (06 Sep, 2009) Summary of changes: Modified: branches/0.16.x/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/0.16.x/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ branches/0.16.x/abcl/src/org/armedbear/lisp/Lisp.java Sun Sep 20 04:31:01 2009 @@ -122,7 +122,7 @@ } catch (Throwable t) { - t.printStackTrace(); + Debug.trace(t); } } @@ -276,7 +276,7 @@ } catch (Go go) { - throw go; + return error(go.getCondition()); } catch (Throw t) { @@ -1041,6 +1041,7 @@ } catch (Throwable t) { + Debug.trace(t); return null; } } @@ -2559,7 +2560,7 @@ } catch (ClassNotFoundException e) { - e.printStackTrace(); + Debug.trace(e); } } From mevenson at common-lisp.net Sun Sep 20 08:34:09 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 20 Sep 2009 04:34:09 -0400 Subject: [armedbear-cvs] r12156 - trunk/abcl Message-ID: Author: mevenson Date: Sun Sep 20 04:34:07 2009 New Revision: 12156 Log: Updated CHANGES to separate out bug fixes from features. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Sep 20 04:34:07 2009 @@ -1,19 +1,25 @@ Version 0.17.0 +============== (unreleased) Features - * Support for loading FASLs from JAR files. +-------- -Bugs. + * Support for loading FASLs from JAR files. +Bugs fixed +---------- * More careful checking for null args in LispStackFrame * Honor appearance of &allow-other-keys in CLOS MAKE-INSTANCE + * Fix #63: GO forms to non-existent TAGBODY labels would exit ABCL Version 0.16.0 +============== (06 SEP 2009) svn://common-lisp.net/project/armedbear/svn/tags/0.16.0/abcl Summary of changes: + ------------------ * Fixed generated wrapper for path names with spaces (Windows) * Fixed ticket #58: Inspection of Java objects in Lisp code * Restored functionality of the built-in profiler @@ -65,10 +71,12 @@ Version 0.15.0 +============== svn://common-lisp.net/project/armedbear/svn/tags/0.15.0/abcl (07 Jun, 2009) Summary of changes: + ------------------- * 2 more MOP exported symbols to support Cells port * Updated FASL version * Support (pre)compilation of functions with a non-null lexical environment @@ -104,18 +112,22 @@ Version 0.14.1 +============== (5 Apr, 2009) svn://common-lisp.net/project/armedbear/svn/tags/0.14.1/abcl Summary of changes: + ------------------- * Include this CHANGES file and scripting files in the tar and zip files Version 0.14.0 +============== (5 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 @@ -141,10 +153,12 @@ 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 From mevenson at common-lisp.net Sun Sep 20 08:57:46 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 20 Sep 2009 04:57:46 -0400 Subject: [armedbear-cvs] r12157 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Sep 20 04:57:46 2009 New Revision: 12157 Log: *INVOKE-DEBUGGER-HOOK* now called before *DEBUGGER-HOOK* (Tobias Rittweiler) Since ANSI requires BREAK to define to bind *DEBUGGER-HOOK* to NIL which would always place calls to BREAK in the native debugger, we define an additional hook *INVOKE-DEBUGGER-HOOK* which is called before *DEBUGGER-HOOK* so that one has the possiblity to install a customer debugger (such as the one provided in SLIME) to handle BREAK conditions. This convention is taken from SBCL. Modified: trunk/abcl/src/org/armedbear/lisp/debug.lisp Modified: trunk/abcl/src/org/armedbear/lisp/debug.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/debug.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/debug.lisp Sun Sep 20 04:57:46 2009 @@ -99,19 +99,32 @@ (type-of condition)) (simple-format *debug-io* " ~A~%" condition))))) +(declaim (inline run-hook)) +(defun run-hook (hook &rest args) + (let ((hook-function (symbol-value hook))) + (when hook-function + (progv (list hook) (list nil) + (apply hook-function args))))) + +(defvar *invoke-debugger-hook* nil + "Like *DEBUGGER-HOOK* but observed by INVOKE-DEBUGGER even when +called by BREAK. This hook is run before *DEBUGGER-HOOK*.") + +;;; We run *INVOKE-DEBUGGER-HOOK* before *DEBUGGER-HOOK* because SBCL +;;; does so, too, and for good reason: This way, you can specify +;;; default debugger behaviour that trumps over whatever the users +;;; wants to do with *DEBUGGER-HOOK*. (defun invoke-debugger (condition) (let ((*saved-backtrace* (sys:backtrace))) - (when *debugger-hook* - (let ((hook-function *debugger-hook*) - (*debugger-hook* nil)) - (funcall hook-function condition hook-function))) + (run-hook '*invoke-debugger-hook* condition *invoke-debugger-hook*) + (run-hook '*debugger-hook* condition *debugger-hook*) (invoke-debugger-report-condition condition) (unless (fboundp 'tpl::repl) (quit)) (let ((original-package *package*)) (with-standard-io-syntax (let ((*package* original-package) - (*print-readably* nil) ; Top-level default. + (*print-readably* nil) ; Top-level default. (*print-structure* nil) (*debug-condition* condition) (level *debug-level*)) From ehuelsmann at common-lisp.net Sun Sep 20 20:37:44 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 20 Sep 2009 16:37:44 -0400 Subject: [armedbear-cvs] r12158 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 20 16:37:40 2009 New Revision: 12158 Log: Change the CHAR_MAX value to the true upper limit of a character. Found by asdf-loading tcr's NAMED-READTABLES package. 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 Sun Sep 20 16:37:40 2009 @@ -2317,7 +2317,7 @@ // ### char-code-limit // "The upper exclusive bound on the value returned by the function CHAR-CODE." - public static final int CHAR_MAX = 256; + public static final int CHAR_MAX = 65535; static { Symbol.CHAR_CODE_LIMIT.initializeConstant(Fixnum.getInstance(CHAR_MAX)); From ehuelsmann at common-lisp.net Sun Sep 20 20:44:49 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 20 Sep 2009 16:44:49 -0400 Subject: [armedbear-cvs] r12159 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 20 16:44:48 2009 New Revision: 12159 Log: Derive the value for CHAR_MAX from Character.MAX_VALUE. 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 Sun Sep 20 16:44:48 2009 @@ -2317,7 +2317,7 @@ // ### char-code-limit // "The upper exclusive bound on the value returned by the function CHAR-CODE." - public static final int CHAR_MAX = 65535; + public static final int CHAR_MAX = Character.MAX_VALUE; static { Symbol.CHAR_CODE_LIMIT.initializeConstant(Fixnum.getInstance(CHAR_MAX)); From astalla at common-lisp.net Sun Sep 20 21:12:23 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 20 Sep 2009 17:12:23 -0400 Subject: [armedbear-cvs] r12160 - trunk/abcl/src/org/armedbear/lisp/scripting Message-ID: Author: astalla Date: Sun Sep 20 17:12:22 2009 New Revision: 12160 Log: JSR-223: methods returning lists in the script engine factory now return immutable lists. Thanks to Clemens Blamauer. Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Sun Sep 20 17:12:22 2009 @@ -21,6 +21,7 @@ package org.armedbear.lisp.scripting; import java.util.ArrayList; +import java.util.Collections; import java.util.List; import javax.script.ScriptEngine; @@ -44,7 +45,7 @@ public List getExtensions() { List extensions = new ArrayList(1); extensions.add("lisp"); - return extensions; + return Collections.unmodifiableList(extensions); } @Override @@ -89,7 +90,7 @@ @Override public List getMimeTypes() { - return new ArrayList(); + return Collections.unmodifiableList(new ArrayList()); } @Override @@ -99,7 +100,7 @@ names.add("cl"); names.add("Lisp"); names.add("Common Lisp"); - return names; + return Collections.unmodifiableList(names); } @Override From mevenson at common-lisp.net Mon Sep 21 10:42:26 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 21 Sep 2009 06:42:26 -0400 Subject: [armedbear-cvs] r12161 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Sep 21 06:42:23 2009 New Revision: 12161 Log: THREADS:MAKE-THREAD :name parameter is now optional. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Mon Sep 21 06:42:23 2009 @@ -108,7 +108,8 @@ this.name = name; map.put(javaThread, this); try { - javaThread.setName(name.getStringValue()); + if (name != NIL) + javaThread.setName(name.getStringValue()); } catch (ConditionThrowable ex) { Debug.trace("Failed to set thread name:"); Debug.trace(ex); @@ -820,7 +821,7 @@ // ### make-thread private static final Primitive MAKE_THREAD = - new Primitive("make-thread", PACKAGE_THREADS, true, "function &key name") + new Primitive("make-thread", PACKAGE_THREADS, true, "function &optional &key name") { @Override public LispObject execute(LispObject[] args) throws ConditionThrowable From ehuelsmann at common-lisp.net Wed Sep 23 06:16:53 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 23 Sep 2009 02:16:53 -0400 Subject: [armedbear-cvs] r12162 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Sep 23 02:16:50 2009 New Revision: 12162 Log: SET-SYNTAX-FROM-CHAR: Copy the fact that the source char *doesn't* have a dispatch table, too. Found by: Tobias C. Rittweiler. Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Readtable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Wed Sep 23 02:16:50 2009 @@ -540,6 +540,10 @@ toReadtable.dispatchTables[toChar] = new DispatchTable(fromReadtable.dispatchTables[fromChar]); } + else + // Don't leave behind dispatch tables when fromChar + // doesn't have one + toReadtable.dispatchTables[toChar] = null; return T; } }; From ehuelsmann at common-lisp.net Sun Sep 27 13:41:57 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 27 Sep 2009 09:41:57 -0400 Subject: [armedbear-cvs] r12163 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 27 09:41:54 2009 New Revision: 12163 Log: Make code self-explanatory: add constants for inline numeric values. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Sep 27 09:41:54 2009 @@ -1904,16 +1904,19 @@ (write-u2 (field-descriptor-index field) stream) (write-u2 0 stream)) ; attributes count -(defconst +field-access-protected+ #x4) ;; subclass accessible -(defconst +field-access-private+ #x2) ;; class-only accessible -(defconst +field-access-public+ #x1) ;; generally accessible -(defconst +field-access-default+ #x0) ;; package accessible, used for LABELS +(defconst +field-flag-final+ #x10) ;; final field +(defconst +field-flag-static+ #x08) ;; static field +(defconst +field-access-protected+ #x04) ;; subclass accessible +(defconst +field-access-private+ #x02) ;; class-only accessible +(defconst +field-access-public+ #x01) ;; generally accessible +(defconst +field-access-default+ #x00) ;; package accessible, used for LABELS (defknown declare-field (t t t) t) (defun declare-field (name descriptor access-flags) (let ((field (make-field name descriptor))) ;; final static - (setf (field-access-flags field) (logior #x10 #x8 access-flags)) + (setf (field-access-flags field) + (logior +field-flag-final+ +field-flag-static+ access-flags)) (setf (field-name-index field) (pool-name (field-name field))) (setf (field-descriptor-index field) (pool-name (field-descriptor field))) (push field *fields*))) From ehuelsmann at common-lisp.net Mon Sep 28 19:55:11 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 28 Sep 2009 15:55:11 -0400 Subject: [armedbear-cvs] r12164 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Sep 28 15:55:08 2009 New Revision: 12164 Log: Correctly identify lexical scoping in case of recursive BLOCKs in compiled code. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.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/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Mon Sep 28 15:55:08 2009 @@ -288,6 +288,13 @@ (*blocks* (cons block *blocks*))) (setf (cddr form) (p1-body (cddr form))) (setf (block-form block) form) + (when (block-non-local-return-p block) + ;; Add a closure variable for RETURN-FROM to use + (push (setf (block-id-variable block) + (make-variable :name (gensym) + :block block + :used-non-locally-p t)) + *all-variables*)) block)) (defun p1-catch (form) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Sep 28 15:55:08 2009 @@ -3912,6 +3912,22 @@ (zerop (variable-writes variable))) (unused-variable variable)))) +(declaim (ftype (function (t) t) emit-new-closure-binding)) +(defun emit-new-closure-binding (variable) + "" + (emit 'new +closure-binding-class+) ;; value c-b + (emit 'dup_x1) ;; c-b value c-b + (emit 'swap) ;; c-b c-b value + (emit-invokespecial-init +closure-binding-class+ + (list +lisp-object+)) ;; c-b + (aload (compiland-closure-register *current-compiland*)) + ;; c-b array + (emit 'swap) ;; array c-b + (emit-push-constant-int (variable-closure-index variable)) + ;; array c-b int + (emit 'swap) ; array index value + (emit 'aastore)) + ;; Generates code to bind variable to value at top of runtime stack. (declaim (ftype (function (t) t) compile-binding)) (defun compile-binding (variable) @@ -3925,18 +3941,7 @@ (emit-invokevirtual +lisp-thread-class+ "bindSpecial" (list +lisp-symbol+ +lisp-object+) nil)) ((variable-closure-index variable) ;; stack: - (emit 'new +closure-binding-class+) ;; value c-b - (emit 'dup_x1) ;; c-b value c-b - (emit 'swap) ;; c-b c-b value - (emit-invokespecial-init +closure-binding-class+ - (list +lisp-object+)) ;; c-b - (aload (compiland-closure-register *current-compiland*)) - ;; c-b array - (emit 'swap) ;; array c-b - (emit-push-constant-int (variable-closure-index variable)) - ;; array c-b int - (emit 'swap) ; array index value - (emit 'aastore)) + (emit-new-closure-binding variable)) (t (sys::%format t "compile-binding~%") (aver nil)))) @@ -4651,10 +4656,18 @@ (sys::%format t "type-of block = ~S~%" (type-of block)) (aver (block-node-p block))) (let* ((*blocks* (cons block *blocks*)) + (*register* *register*) (BEGIN-BLOCK (gensym)) (END-BLOCK (gensym)) (BLOCK-EXIT (block-exit block))) (setf (block-target block) target) + (when (block-id-variable block) + ;; we have a block variable; that should be a closure variable + (assert (not (null (variable-closure-index (block-id-variable block))))) + (emit 'new +lisp-object-class+) + (emit 'dup) + (emit-invokespecial-init +lisp-object-class+ '()) + (emit-new-closure-binding (block-id-variable block))) (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) (label BEGIN-BLOCK) ; Start of protected range, for non-local returns @@ -4665,20 +4678,19 @@ ;; We need a handler to catch non-local RETURNs. (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one (let ((HANDLER (gensym)) - (RETHROW (gensym))) + (THIS-BLOCK (gensym))) (label HANDLER) ;; The Return object is on the runtime stack. Stack depth is 1. (emit 'dup) ; Stack depth is 2. (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2. - (compile-form `',(block-exit block) 'stack nil) ; Tag. Stack depth is 3. - ;; If it's not the tag we're looking for... - (emit 'if_acmpne RETHROW) ; Stack depth is 1. - (emit 'getfield +lisp-return-class+ "result" +lisp-object+) - (emit-move-from-stack target) ; Stack depth is 0. - (emit 'goto BLOCK-EXIT) - (label RETHROW) + (emit-push-variable (block-id-variable block)) + ;; If it's not the block we're looking for... + (emit 'if_acmpeq THIS-BLOCK) ; Stack depth is 1. ;; Not the tag we're looking for. (emit 'athrow) + (label THIS-BLOCK) + (emit 'getfield +lisp-return-class+ "result" +lisp-object+) + (emit-move-from-stack target) ; Stack depth is 0. ;; Finally... (push (make-handler :from BEGIN-BLOCK :to END-BLOCK @@ -4717,7 +4729,7 @@ (cond ((node-constant-p result-form) (emit 'new +lisp-return-class+) (emit 'dup) - (compile-form `',(block-exit block) 'stack nil) ; Tag. + (emit-push-variable (block-id-variable block)) (emit-clear-values) (compile-form result-form 'stack nil)) ; Result. (t @@ -4727,7 +4739,7 @@ (compile-form result-form temp-register nil) ; Result. (emit 'new +lisp-return-class+) (emit 'dup) - (compile-form `',(block-exit block) 'stack nil) ; Tag. + (emit-push-variable (block-id-variable block)) (aload temp-register)))) (emit-invokespecial-init +lisp-return-class+ (lisp-object-arg-types 2)) (emit 'athrow) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Mon Sep 28 15:55:08 2009 @@ -409,7 +409,10 @@ (exit (gensym)) target ;; True if there is a non-local RETURN from this block. - non-local-return-p) + non-local-return-p + ;; Contains a variable whose value uniquely identifies the + ;; lexical scope from this block, to be used by RETURN-FROM + id-variable) (defknown make-block-node (t) t) (defun make-block-node (name) (let ((block (%make-block-node name))) From ehuelsmann at common-lisp.net Tue Sep 29 19:09:03 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 29 Sep 2009 15:09:03 -0400 Subject: [armedbear-cvs] r12165 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Sep 29 15:08:59 2009 New Revision: 12165 Log: Removal of duplication of TAGBODY processing code in DO*/DO and TAGBODY. Modified: trunk/abcl/src/org/armedbear/lisp/Do.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Primitives.java 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 Tue Sep 29 15:08:59 2009 @@ -120,62 +120,21 @@ list = list.cdr(); } // Look for tags. - LispObject remaining = body; - while (remaining != NIL) - { - LispObject current = remaining.car(); - remaining = remaining.cdr(); - if (current instanceof Cons) - continue; - // It's a tag. - ext.addTagBinding(current, remaining); - } + LispObject localTags = preprocessTagBody(body, ext); + LispObject blockId = new LispObject(); try { // Implicit block. - ext.addBlock(NIL, new LispObject()); + ext.addBlock(NIL, blockId); while (true) { // Execute body. // Test for termination. if (eval(end_test_form, ext, thread) != NIL) break; - remaining = body; - while (remaining != NIL) - { - LispObject current = remaining.car(); - if (current instanceof Cons) - { - try - { - // Handle GO inline if possible. - if (current.car() == Symbol.GO) - { - LispObject tag = current.cadr(); - Binding binding = ext.getTagBinding(tag); - if (binding != null && binding.value != null) - { - remaining = binding.value; - continue; - } - throw new Go(tag); - } - eval(current, ext, thread); - } - catch (Go go) - { - LispObject tag = go.getTag(); - Binding binding = ext.getTagBinding(tag); - if (binding != null && binding.value != null) - { - remaining = binding.value; - continue; - } - throw go; - } - } - remaining = remaining.cdr(); - } + + processTagBody(body, localTags, ext); + // Update variables. if (sequential) { @@ -230,7 +189,7 @@ } catch (Return ret) { - if (ret.getTag() == NIL) + if (ret.getBlock() == blockId) { return ret.getResult(); } 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 Sep 29 15:08:59 2009 @@ -626,6 +626,81 @@ return result; } + public static final LispObject preprocessTagBody(LispObject body, + Environment env) + throws ConditionThrowable + { + LispObject localTags = NIL; // Tags that are local to this TAGBODY. + while (body != NIL) + { + LispObject current = body.car(); + body = ((Cons)body).cdr; + if (current instanceof Cons) + continue; + // It's a tag. + env.addTagBinding(current, body); + localTags = new Cons(current, localTags); + } + return localTags; + } + + public static final LispObject processTagBody(LispObject body, + LispObject localTags, + Environment env) + throws ConditionThrowable + { + LispObject remaining = body; + LispThread thread = LispThread.currentThread(); + while (remaining != NIL) + { + LispObject current = remaining.car(); + if (current instanceof Cons) + { + try { + // Handle GO inline if possible. + if (((Cons)current).car == Symbol.GO) + { + if (interrupted) + handleInterrupt(); + LispObject tag = current.cadr(); + Binding binding = env.getTagBinding(tag); + if (binding == null) + return error(new ControlError("No tag named " + + tag.writeToString() + + " is currently visible.")); + else if (memql(tag, localTags)) + { + if (binding.value != null) + { + remaining = binding.value; + continue; + } + } + throw new Go(tag); + } + eval(current, env, thread); + } + catch (Go go) + { + LispObject tag = go.getTag(); + if (memql(tag, localTags)) + { + Binding binding = env.getTagBinding(tag); + if (binding != null && binding.value != null) + { + remaining = binding.value; + continue; + } + } + throw go; + } + } + remaining = ((Cons)remaining).cdr; + } + thread._values = null; + return NIL; + } + // Environment wrappers. private static final boolean isSpecial(Symbol sym, LispObject ownSpecials, Environment env) 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 Tue Sep 29 15:08:59 2009 @@ -3496,65 +3496,7 @@ throws ConditionThrowable { Environment ext = new Environment(env); - LispObject localTags = NIL; // Tags that are local to this TAGBODY. - LispObject body = args; - while (body != NIL) - { - LispObject current = body.car(); - body = ((Cons)body).cdr; - if (current instanceof Cons) - continue; - // It's a tag. - ext.addTagBinding(current, body); - localTags = new Cons(current, localTags); - } - final LispThread thread = LispThread.currentThread(); - LispObject remaining = args; - while (remaining != NIL) - { - LispObject current = remaining.car(); - if (current instanceof Cons) - { - try - { - // Handle GO inline if possible. - if (((Cons)current).car == Symbol.GO) - { - if (interrupted) - handleInterrupt(); - LispObject tag = current.cadr(); - if (memql(tag, localTags)) - { - Binding binding = ext.getTagBinding(tag); - if (binding != null && binding.value != null) - { - remaining = binding.value; - continue; - } - } - throw new Go(tag); - } - eval(current, ext, thread); - } - catch (Go go) - { - LispObject tag = go.getTag(); - if (memql(tag, localTags)) - { - Binding binding = ext.getTagBinding(tag); - if (binding != null && binding.value != null) - { - remaining = binding.value; - continue; - } - } - throw go; - } - } - remaining = ((Cons)remaining).cdr; - } - thread._values = null; - return NIL; + return processTagBody(args, preprocessTagBody(args, ext), ext); } }; From ehuelsmann at common-lisp.net Tue Sep 29 19:54:03 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 29 Sep 2009 15:54:03 -0400 Subject: [armedbear-cvs] r12166 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Sep 29 15:54:02 2009 New Revision: 12166 Log: More TAGBODY processing duplication removal; DOTIMES and DOLIST this time. Modified: trunk/abcl/src/org/armedbear/lisp/dolist.java trunk/abcl/src/org/armedbear/lisp/dotimes.java 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 Tue Sep 29 15:54:02 2009 @@ -57,25 +57,18 @@ LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); bodyForm = bodyAndDecls.car(); + LispObject blockId = new LispObject(); try { final Environment ext = new Environment(env); // Implicit block. - ext.addBlock(NIL, new LispObject()); + ext.addBlock(NIL, blockId); // Evaluate the list form. LispObject list = checkList(eval(listForm, ext, thread)); // Look for tags. LispObject remaining = bodyForm; - while (remaining != NIL) - { - LispObject current = remaining.car(); - remaining = remaining.cdr(); - if (current instanceof Cons) - continue; - // It's a tag. - ext.addTagBinding(current, remaining); - } - // Establish a reusable binding. + LispObject localTags = preprocessTagBody(bodyForm, ext); + final Object binding; if (specials != NIL && memq(var, specials)) { @@ -104,42 +97,9 @@ ((SpecialBinding)binding).value = list.car(); else ((Binding)binding).value = list.car(); - LispObject body = bodyForm; - while (body != NIL) - { - LispObject current = body.car(); - if (current instanceof Cons) - { - try - { - // Handle GO inline if possible. - if (current.car() == Symbol.GO) - { - LispObject tag = current.cadr(); - Binding b = ext.getTagBinding(tag); - if (b != null && b.value != null) - { - body = b.value; - continue; - } - throw new Go(tag); - } - eval(current, ext, thread); - } - catch (Go go) - { - LispObject tag = go.getTag(); - Binding b = ext.getTagBinding(tag); - if (b != null && b.value != null) - { - body = b.value; - continue; - } - throw go; - } - } - body = body.cdr(); - } + + processTagBody(bodyForm, localTags, ext); + list = list.cdr(); if (interrupted) handleInterrupt(); @@ -153,7 +113,7 @@ } catch (Return ret) { - if (ret.getTag() == NIL) + if (ret.getBlock() == blockId) { return ret.getResult(); } 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 Tue Sep 29 15:54:02 2009 @@ -56,25 +56,14 @@ LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); bodyForm = bodyAndDecls.car(); + LispObject blockId = new LispObject(); try { LispObject limit = eval(countForm, env, thread); Environment ext = new Environment(env); - LispObject localTags = NIL; // Tags that are local to this TAGBODY. - // Look for tags. - LispObject remaining = bodyForm; - while (remaining != NIL) - { - LispObject current = remaining.car(); - remaining = remaining.cdr(); - if (current instanceof Cons) - continue; - // It's a tag. - ext.addTagBinding(current, remaining); - localTags = new Cons(current, localTags); - } - // Implicit block. - ext.addBlock(NIL, new LispObject()); + LispObject localTags = preprocessTagBody(bodyForm, ext); + + ext.addBlock(NIL, blockId); LispObject result; // Establish a reusable binding. final Object binding; @@ -109,48 +98,9 @@ ((SpecialBinding)binding).value = Fixnum.getInstance(i); else ((Binding)binding).value = Fixnum.getInstance(i); - LispObject body = bodyForm; - while (body != NIL) - { - LispObject current = body.car(); - if (current instanceof Cons) - { - try - { - // Handle GO inline if possible. - if (current.car() == Symbol.GO) - { - LispObject tag = current.cadr(); - if (memql(tag, localTags)) - { - Binding b = ext.getTagBinding(tag); - if (b != null && b.value != null) - { - body = b.value; - continue; - } - } - throw new Go(tag); - } - eval(current, ext, thread); - } - catch (Go go) - { - LispObject tag = go.getTag(); - if (memql(tag, localTags)) - { - Binding b = ext.getTagBinding(tag); - if (b != null && b.value != null) - { - body = b.value; - continue; - } - } - throw go; - } - } - body = body.cdr(); - } + + processTagBody(bodyForm, localTags, ext); + if (interrupted) handleInterrupt(); } @@ -169,48 +119,9 @@ ((SpecialBinding)binding).value = i; else ((Binding)binding).value = i; - LispObject body = bodyForm; - while (body != NIL) - { - LispObject current = body.car(); - if (current instanceof Cons) - { - try - { - // Handle GO inline if possible. - if (current.car() == Symbol.GO) - { - LispObject tag = current.cadr(); - if (memql(tag, localTags)) - { - Binding b = ext.getTagBinding(tag); - if (b != null && b.value != null) - { - body = b.value; - continue; - } - } - throw new Go(tag); - } - eval(current, ext, thread); - } - catch (Go go) - { - LispObject tag = go.getTag(); - if (memql(tag, localTags)) - { - Binding b = ext.getTagBinding(tag); - if (b != null && b.value != null) - { - body = b.value; - continue; - } - } - throw go; - } - } - body = body.cdr(); - } + + processTagBody(bodyForm, localTags, ext); + i = i.incr(); if (interrupted) handleInterrupt(); @@ -227,7 +138,7 @@ } catch (Return ret) { - if (ret.getTag() == NIL) + if (ret.getBlock() == blockId) { return ret.getResult(); } From ehuelsmann at common-lisp.net Tue Sep 29 21:18:57 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 29 Sep 2009 17:18:57 -0400 Subject: [armedbear-cvs] r12167 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Sep 29 17:18:55 2009 New Revision: 12167 Log: Reorder statements to make sure the implicit block includes the evaluation of the countForm. This fixes breakage of the DOTIMES.8 test from r12166. Modified: trunk/abcl/src/org/armedbear/lisp/dotimes.java 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 Tue Sep 29 17:18:55 2009 @@ -59,11 +59,12 @@ LispObject blockId = new LispObject(); try { - LispObject limit = eval(countForm, env, thread); Environment ext = new Environment(env); + ext.addBlock(NIL, blockId); + + LispObject limit = eval(countForm, ext, thread); LispObject localTags = preprocessTagBody(bodyForm, ext); - ext.addBlock(NIL, blockId); LispObject result; // Establish a reusable binding. final Object binding; From ehuelsmann at common-lisp.net Wed Sep 30 19:10:54 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 30 Sep 2009 15:10:54 -0400 Subject: [armedbear-cvs] r12168 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Sep 30 15:10:51 2009 New Revision: 12168 Log: Correct identification of the lexical context of a GO in relation to its TAGBODY. The change applies to both compiled and interpreted code, both of which didn't identify the correct TAGBODY to which the GO belonged. Modified: trunk/abcl/src/org/armedbear/lisp/Binding.java trunk/abcl/src/org/armedbear/lisp/Environment.java trunk/abcl/src/org/armedbear/lisp/Go.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/compiler-pass1.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/Binding.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Binding.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Binding.java Wed Sep 30 15:10:51 2009 @@ -37,6 +37,7 @@ final class Binding { final LispObject symbol; + LispObject tagbody = null; LispObject value; boolean specialp; final Binding next; @@ -47,4 +48,11 @@ this.value = value; this.next = next; } + + Binding(LispObject symbol, LispObject tagbody, + LispObject value, Binding next) + { + this(symbol, value, next); + this.tagbody = tagbody; + } } 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 Wed Sep 30 15:10:51 2009 @@ -182,9 +182,9 @@ return null; } - public void addTagBinding(LispObject tag, LispObject code) + public void addTagBinding(LispObject tag, LispObject tagbody, LispObject code) { - tags = new Binding(tag, code, tags); + tags = new Binding(tag, tagbody, code, tags); } public Binding getTagBinding(LispObject tag) Modified: trunk/abcl/src/org/armedbear/lisp/Go.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Go.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Go.java Wed Sep 30 15:10:51 2009 @@ -35,13 +35,20 @@ public final class Go extends ConditionThrowable { + public final LispObject tagbody; public final LispObject tag; - public Go(LispObject tag) + public Go(LispObject tagbody, LispObject tag) { + this.tagbody = tagbody; this.tag = tag; } + public LispObject getTagBody() + { + return tagbody; + } + public LispObject getTag() { return tag; Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Sep 30 15:10:51 2009 @@ -638,7 +638,7 @@ if (current instanceof Cons) continue; // It's a tag. - env.addTagBinding(current, body); + env.addTagBinding(current, env, body); localTags = new Cons(current, localTags); } return localTags; @@ -676,14 +676,15 @@ continue; } } - throw new Go(tag); + throw new Go(binding.tagbody, tag); } eval(current, env, thread); } catch (Go go) { - LispObject tag = go.getTag(); - if (memql(tag, localTags)) + LispObject tag; + if (go.getTagBody() == env + && memql(tag = go.getTag(), localTags)) { Binding binding = env.getTagBinding(tag); if (binding != null && binding.value != null) 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 Wed Sep 30 15:10:51 2009 @@ -3515,7 +3515,7 @@ return error(new ControlError("No tag named " + args.car().writeToString() + " is currently visible.")); - throw new Go(args.car()); + throw new Go(binding.tagbody, args.car()); } }; 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 Sep 30 15:10:51 2009 @@ -420,6 +420,12 @@ (setf live nil)) (push (p1 subform) new-body)))) (setf (tagbody-form block) (list* 'TAGBODY (nreverse new-body)))) + (when (some #'tag-used-non-locally (tagbody-tags block)) + (push (setf (tagbody-id-variable block) + (make-variable :name (gensym) + :block block + :used-non-locally-p t)) + *all-variables*)) block)) (defknown p1-go (t) t) 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 Sep 30 15:10:51 2009 @@ -4469,12 +4469,20 @@ (body (cdr form)) (BEGIN-BLOCK (gensym)) (END-BLOCK (gensym)) + (RETHROW (gensym)) (EXIT (gensym)) (must-clear-values nil)) ;; Scan for tags. (dolist (tag (tagbody-tags block)) (push tag *visible-tags*)) + (when (tagbody-id-variable block) + ;; we have a block variable; that should be a closure variable + (assert (not (null (variable-closure-index (tagbody-id-variable block))))) + (emit 'new +lisp-object-class+) + (emit 'dup) + (emit-invokespecial-init +lisp-object-class+ '()) + (emit-new-closure-binding (tagbody-id-variable block))) (label BEGIN-BLOCK) (do* ((rest body (cdr rest)) (subform (car rest) (car rest))) @@ -4506,7 +4514,10 @@ (emit 'dup) (astore go-register) ;; Get the tag. - (emit 'checkcast +lisp-go-class+) + (emit 'getfield +lisp-go-class+ "tagbody" +lisp-object+) ; Stack depth is still 1. + (emit-push-variable (tagbody-id-variable block)) + (emit 'if_acmpne RETHROW) ;; Not this TAGBODY + (aload go-register) (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1. (astore tag-register) ;; Don't actually generate comparisons for tags @@ -4525,6 +4536,7 @@ (emit 'goto (tag-label tag)) (label NEXT))) ;; Not found. Re-throw Go. + (label RETHROW) (aload go-register) (emit 'athrow) ;; Finally... @@ -4564,8 +4576,9 @@ ;; Non-local GO. (emit 'new +lisp-go-class+) (emit 'dup) + (emit-push-variable (tagbody-id-variable (tag-block tag))) (compile-form `',(tag-label tag) 'stack nil) ; Tag. - (emit-invokespecial-init +lisp-go-class+ (lisp-object-arg-types 1)) + (emit-invokespecial-init +lisp-go-class+ (lisp-object-arg-types 2)) (emit 'athrow) ;; Following code will not be reached, but is needed for JVM stack ;; consistency. 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 Wed Sep 30 15:10:51 2009 @@ -383,7 +383,11 @@ (:constructor %make-tagbody-node ())) ;; True if a tag in this tagbody is the target of a non-local GO. non-local-go-p - tags) + ;; Tags in the tagbody form; a list of tag structures + tags + ;; Contains a variable whose value uniquely identifies the + ;; lexical scope from this block, to be used by GO + id-variable) (defknown make-tagbody-node () t) (defun make-tagbody-node () (let ((block (%make-tagbody-node)))