From ehuelsmann at common-lisp.net Fri May 1 19:26:43 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 May 2009 15:26:43 -0400 Subject: [armedbear-cvs] r11809 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 1 15:26:40 2009 New Revision: 11809 Log: Use a single routine to calculate the classfile pathname in two places. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri May 1 15:26:40 2009 @@ -39,13 +39,20 @@ (defvar *output-file-pathname*) +(declaim (ftype (function (t) t) compute-classfile-name)) +(defun compute-classfile-name (n &optional (output-file-pathname + *output-file-pathname*)) + "Computes the name of the class file associated with number `n'." + (let ((name + (%format nil "~A-~D" + (substitute #\_ #\. + (pathname-name output-file-pathname)) n))) + (namestring (merge-pathnames (make-pathname :name name :type "cls") + output-file-pathname)))) + (declaim (ftype (function () t) next-classfile-name)) (defun next-classfile-name () - (let ((name (%format nil "~A-~D" - (substitute #\_ #\. (pathname-name *output-file-pathname*)) - (incf *class-number*)))) - (namestring (merge-pathnames (make-pathname :name name :type "cls") - *output-file-pathname*)))) + (compute-classfile-name (incf *class-number*))) (defmacro report-error (&rest forms) `(handler-case (progn , at forms) @@ -471,10 +478,7 @@ output-file))) (pathnames ())) (dotimes (i *class-number*) - (let* ((file-namestring (%format nil "~A-~D.cls" - (substitute #\_ #\. (pathname-name output-file)) - (1+ i))) - (pathname (merge-pathnames file-namestring output-file))) + (let* ((pathname (compute-classfile-name (1+ i)))) (when (probe-file pathname) (push pathname pathnames)))) (setf pathnames (nreverse pathnames)) From ehuelsmann at common-lisp.net Fri May 1 20:40:07 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 May 2009 16:40:07 -0400 Subject: [armedbear-cvs] r11810 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 1 16:40:07 2009 New Revision: 11810 Log: Fix file compilation with :output-file parameter compiling code which uses a :compile-toplevel EVAL-WHEN condition. Found by: Stas Boukarev (stassats at gmail) Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri May 1 16:40:07 2009 @@ -313,7 +313,13 @@ (t ;; (setf form (precompile-form form nil)) (note-toplevel-form form) - (setf form (convert-toplevel-form form)) + (let ((new-form (convert-toplevel-form form))) + (when (consp new-form) + (dump-form new-form stream) + (%stream-terpri stream))) + (when compile-time-too + (eval form)) + (return-from process-toplevel-form) ))))))) (when (consp form) (dump-form form stream) From ehuelsmann at common-lisp.net Fri May 1 20:43:46 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 May 2009 16:43:46 -0400 Subject: [armedbear-cvs] r11811 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 1 16:43:46 2009 New Revision: 11811 Log: Add documentation as to why we do what we were doing. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri May 1 16:43:46 2009 @@ -314,6 +314,11 @@ ;; (setf form (precompile-form form nil)) (note-toplevel-form form) (let ((new-form (convert-toplevel-form form))) + ;; The converted form depends on the loader + ;; but since we don't own the loader here, + ;; we'll dump the converted form and eval + ;; the original one (which won't depend on the loader + ;; because it doesn't contain a compiled function) (when (consp new-form) (dump-form new-form stream) (%stream-terpri stream))) From ehuelsmann at common-lisp.net Fri May 1 21:40:11 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 May 2009 17:40:11 -0400 Subject: [armedbear-cvs] r11812 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 1 17:40:08 2009 New Revision: 11812 Log: Followup to r11810: revert it and use a different strategy which works with *all* forms (which load compiled functions); based on a report by Stas that system compilation doesn't work with r11810. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri May 1 17:40:08 2009 @@ -313,24 +313,18 @@ (t ;; (setf form (precompile-form form nil)) (note-toplevel-form form) - (let ((new-form (convert-toplevel-form form))) - ;; The converted form depends on the loader - ;; but since we don't own the loader here, - ;; we'll dump the converted form and eval - ;; the original one (which won't depend on the loader - ;; because it doesn't contain a compiled function) - (when (consp new-form) - (dump-form new-form stream) - (%stream-terpri stream))) - (when compile-time-too - (eval form)) - (return-from process-toplevel-form) + (setf form (convert-toplevel-form form)) ))))))) (when (consp form) (dump-form form stream) (%stream-terpri stream)) - (when compile-time-too - (eval form))) + ;; Make sure the compiled-function loader knows where + ;; to load the compiled functions. Note that this trickery + ;; was already used in verify-load before I used it, + ;; however, binding *load-truename* isn't fully compliant, I think. + (let ((*load-truename* *output-file-pathname*)) + (when compile-time-too + (eval form)))) (declaim (ftype (function (t) t) convert-ensure-method)) (defun convert-ensure-method (form) From ehuelsmann at common-lisp.net Sat May 2 19:36:47 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 May 2009 15:36:47 -0400 Subject: [armedbear-cvs] r11813 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 2 15:36:44 2009 New Revision: 11813 Log: Fix building in a path with spaces. Found by: Mark Tarver Fixes: https://sourceforge.net/tracker/?func=detail&atid=475785&aid=2784411&group_id=55057 Modified: trunk/abcl/build-abcl.lisp trunk/abcl/src/org/armedbear/lisp/Site.java Modified: trunk/abcl/build-abcl.lisp ============================================================================== --- trunk/abcl/build-abcl.lisp (original) +++ trunk/abcl/build-abcl.lisp Sat May 2 15:36:44 2009 @@ -13,10 +13,20 @@ (in-package #:build-abcl) +(defun comp (string char) + "Chops off the character at the end of `string' if it matches char" + (let ((len (length string))) + (if (eql char (char string (1- len))) + (subseq string 0 (1- len)) + string))) + (defun safe-namestring (pathname) - (let ((string (namestring pathname))) + (let* ((string (namestring pathname)) + (len (length string))) (when (position #\space string) - (setf string (concatenate 'string "\"" string "\""))) + (setf string (concatenate 'string "\"" + (comp string #\\) + "\""))) string)) @@ -309,13 +319,14 @@ (cmdline (with-output-to-string (s) (princ *java-compiler-command-line-prefix* s) (princ " -d " s) - (princ *build-root* s) + (princ (safe-namestring *build-root*) s) (princ #\Space s) (dolist (source-file source-files) (princ - (if (equal (pathname-directory source-file) dir) - (file-namestring source-file) - (namestring source-file)) + (safe-namestring + (if (equal (pathname-directory source-file) dir) + (file-namestring source-file) + (namestring source-file))) s) (princ #\space s)))) (status (run-shell-command cmdline :directory *abcl-dir*))) @@ -323,7 +334,7 @@ (t (ensure-directories-exist *build-root*) (dolist (source-file source-files t) - (unless (java-compile-file source-file) + (unless (java-compile-file (safe-namestring source-file)) (format t "Build failed.~%") (return nil))))))))) Modified: trunk/abcl/src/org/armedbear/lisp/Site.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Site.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Site.java Sat May 2 15:36:44 2009 @@ -35,6 +35,7 @@ import java.io.File; import java.net.URL; +import java.net.URLDecoder; public final class Site extends Lisp { @@ -47,6 +48,13 @@ String protocol = url.getProtocol(); if (protocol != null && protocol.equals("file")) { String path = url.getPath(); + try { + path = URLDecoder.decode(path, "UTF-8"); + } + catch (java.io.UnsupportedEncodingException uee) { + // can't happen: Java implementations are required to + // support UTF-8 + } int index = path.lastIndexOf('/'); if (index >= 0) { lispHome = path.substring(0, index + 1); From ehuelsmann at common-lisp.net Sat May 2 20:14:17 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 May 2009 16:14:17 -0400 Subject: [armedbear-cvs] r11814 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 2 16:14:16 2009 New Revision: 11814 Log: Resolve part 1 of ticket #21: Don't use JSR and RET JVM instructions. Note: This solution inlines the cleanup twice. Since our own build only increases by a few bytes, we'll go with this solution until there's a real issue for someone. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat May 2 16:14:16 2009 @@ -7864,12 +7864,10 @@ (exception-register (allocate-register)) (result-register (allocate-register)) (values-register (allocate-register)) - (return-address-register (allocate-register)) (BEGIN-PROTECTED-RANGE (gensym)) (END-PROTECTED-RANGE (gensym)) (HANDLER (gensym)) - (EXIT (gensym)) - (CLEANUP (gensym))) + (EXIT (gensym))) ;; Make sure there are no leftover multiple return values from previous calls. (emit-clear-values) @@ -7880,21 +7878,17 @@ (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) (astore values-register) (label END-PROTECTED-RANGE)) - (emit 'jsr CLEANUP) + (dolist (subform cleanup-forms) + (compile-form subform nil nil)) (emit 'goto EXIT) ; Jump over handler. (label HANDLER) ; Start of exception handler. ;; The Throwable object is on the runtime stack. Stack depth is 1. (astore exception-register) - (emit 'jsr CLEANUP) ; Call cleanup forms. + (dolist (subform cleanup-forms) + (compile-form subform nil nil)) (emit-clear-values) (aload exception-register) (emit 'athrow) ; Re-throw exception. - (label CLEANUP) ; Cleanup forms. - ;; Return address is on stack here. - (astore return-address-register) - (dolist (subform cleanup-forms) - (compile-form subform nil nil)) - (emit 'ret return-address-register) (label EXIT) ;; Restore multiple values returned by protected form. (emit-push-current-thread) From ehuelsmann at common-lisp.net Sat May 2 20:40:55 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 May 2009 16:40:55 -0400 Subject: [armedbear-cvs] r11815 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 2 16:40:54 2009 New Revision: 11815 Log: Be sure to decode URL.getPath() results before using it as paths. Result from an audit after finding we didn't build on paths with spaces in them. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sat May 2 16:40:54 2009 @@ -39,6 +39,7 @@ import java.io.IOException; import java.io.InputStream; import java.net.URL; +import java.net.URLDecoder; import java.util.zip.ZipEntry; import java.util.zip.ZipException; import java.util.zip.ZipFile; @@ -508,7 +509,15 @@ private static final String getPath(URL url) { if (url != null) { - String path = url.getPath(); + String path; + try { + path = URLDecoder.decode(url.getPath(),"UTF-8"); + } + catch (java.io.UnsupportedEncodingException uee) { + // Can't happen: every Java is supposed to support + // at least UTF-8 encoding + path = null; + } if (path != null) { if (Utilities.isPlatformWindows) { if (path.length() > 0 && path.charAt(0) == '/') Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat May 2 16:40:54 2009 @@ -36,6 +36,7 @@ import java.io.File; import java.io.IOException; import java.net.URL; +import java.net.URLDecoder; import java.util.StringTokenizer; public class Pathname extends LispObject @@ -66,7 +67,15 @@ { String protocol = url.getProtocol(); if ("jar".equals(protocol)) { - String s = url.getPath(); + String s; + try { + s = URLDecoder.decode(url.getPath(),"UTF-8"); + } + catch (java.io.UnsupportedEncodingException uee) { + // Can't happen: every Java is supposed to support + // at least UTF-8 encoding + s = null; + } if (s.startsWith("file:")) { int index = s.indexOf("!/"); String container = s.substring(5, index); @@ -83,7 +92,15 @@ return; } } else if ("file".equals(protocol)) { - String s = url.getPath(); + String s; + try { + s = URLDecoder.decode(url.getPath(),"UTF-8"); + } + catch (java.io.UnsupportedEncodingException uee) { + // Can't happen: every Java is supposed to support + // at least UTF-8 encoding + s = null; + } if (s != null && s.startsWith("file:")) { init(s.substring(5)); return; From ehuelsmann at common-lisp.net Sat May 2 22:06:37 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 May 2009 18:06:37 -0400 Subject: [armedbear-cvs] r11816 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 2 18:06:36 2009 New Revision: 11816 Log: Selectively clear values in UNWIND-PROTECT: don't clear if the protected form returns a single value. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat May 2 18:06:36 2009 @@ -7874,9 +7874,10 @@ (let* ((*blocks* (cons block *blocks*))) (label BEGIN-PROTECTED-RANGE) (compile-form protected-form result-register nil) - (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) - (astore values-register) + (unless (single-valued-p protected-form) + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (astore values-register)) (label END-PROTECTED-RANGE)) (dolist (subform cleanup-forms) (compile-form subform nil nil)) @@ -7886,14 +7887,15 @@ (astore exception-register) (dolist (subform cleanup-forms) (compile-form subform nil nil)) - (emit-clear-values) + (maybe-emit-clear-values cleanup-forms) (aload exception-register) (emit 'athrow) ; Re-throw exception. (label EXIT) ;; Restore multiple values returned by protected form. - (emit-push-current-thread) - (aload values-register) - (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+) + (unless (single-valued-p protected-form) + (emit-push-current-thread) + (aload values-register) + (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+)) ;; Result. (aload result-register) (emit-move-from-stack target) From ehuelsmann at common-lisp.net Sun May 3 06:10:08 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 02:10:08 -0400 Subject: [armedbear-cvs] r11817 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 02:10:01 2009 New Revision: 11817 Log: A little bit of reindenting; making some lines < 80 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 May 3 02:10:01 2009 @@ -3991,7 +3991,8 @@ ;; Save current dynamic environment. (setf (block-environment-register block) (allocate-register)) (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+) (astore (block-environment-register block)) (label label-START)) ;; Make sure there are no leftover values from previous calls. @@ -4016,14 +4017,14 @@ ;; Did we get just one value? (aload values-register) (emit 'ifnull LABEL1) - ;; Reaching here, we have multiple values (or no values at all). We need - ;; the slow path if we have more variables than values. + ;; Reaching here, we have multiple values (or no values at all). + ;; We need the slow path if we have more variables than values. (aload values-register) (emit 'arraylength) (emit-push-constant-int (length vars)) (emit 'if_icmplt LABEL1) - ;; Reaching here, we have enough values for all the variables. We can use - ;; the values we have. This is the fast path. + ;; Reaching here, we have enough values for all the variables. + ;; We can use the values we have. This is the fast path. (aload values-register) (emit 'goto LABEL2) (label LABEL1) @@ -4062,7 +4063,8 @@ (label label-EXIT) (aload *thread*) (aload (block-environment-register block)) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+) (push (make-handler :from label-START :to label-END :code label-END @@ -4092,16 +4094,20 @@ (when (eql (variable-writes source-var) 0) ;; We can eliminate the variable. ;; FIXME This may no longer be true when we start tracking writes! - (aver (= (variable-reads variable) (length (variable-references variable)))) + (aver (= (variable-reads variable) + (length (variable-references variable)))) (dolist (ref (variable-references variable)) (aver (eq (var-ref-variable ref) variable)) (setf (var-ref-variable ref) source-var)) ;; Check for DOTIMES limit variable. - (when (get (variable-name variable) 'sys::dotimes-limit-variable-p) - (let* ((symbol (get (variable-name variable) 'sys::dotimes-index-variable-name)) + (when (get (variable-name variable) + 'sys::dotimes-limit-variable-p) + (let* ((symbol (get (variable-name variable) + 'sys::dotimes-index-variable-name)) (index-variable (find-variable symbol (block-vars block)))) (when index-variable - (setf (get (variable-name index-variable) 'sys::dotimes-limit-variable-name) + (setf (get (variable-name index-variable) + 'sys::dotimes-limit-variable-name) (variable-name source-var))))) (push variable removed))))))) ((fixnump initform) @@ -4271,7 +4277,9 @@ ;; Now allocate the register. (allocate-variable-register variable)) (cond ((variable-special-p variable) - (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register)))) + (emit-move-from-stack + (setf (variable-temp-register variable) + (allocate-register)))) ((variable-representation variable) (emit-move-to-variable variable)) (t @@ -4386,7 +4394,8 @@ ;; We need to save current dynamic environment. (setf (block-environment-register block) (allocate-register)) (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+) (astore (block-environment-register block)) (label label-START)) (propagate-vars block) @@ -4544,7 +4553,8 @@ ;; Restore dynamic environment. (aload *thread*) (aload register) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+)) (maybe-generate-interrupt-check) (emit 'goto (tag-label tag)) (return-from p2-go)))) @@ -4821,7 +4831,8 @@ (single-valued-p values-form)) (emit-clear-values)) (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+) (astore environment-register) (label label-START) ;; Compile call to Lisp.progvBindVars(). @@ -4834,14 +4845,16 @@ (label label-END) (aload *thread*) (aload environment-register) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+) (emit 'athrow) ;; Restore dynamic environment. (label label-EXIT) (aload *thread*) (aload environment-register) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+) (fix-boxing representation nil) (push (make-handler :from label-START :to label-END From ehuelsmann at common-lisp.net Sun May 3 08:07:29 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 04:07:29 -0400 Subject: [armedbear-cvs] r11818 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 04:07:28 2009 New Revision: 11818 Log: Harmonize the concept of 'block needing non-local-exit' by centralizing the definition. 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 May 3 04:07:28 2009 @@ -316,7 +316,7 @@ (dolist (enclosing-block *blocks*) (when (eq enclosing-block block) (return nil)) - (when (equal (block-name enclosing-block) '(UNWIND-PROTECT)) + (when (block-requires-non-local-exit-p enclosing-block) (return t))))) (dformat t "p1-return-from protected = ~S~%" protected) (when protected @@ -369,7 +369,7 @@ (dolist (enclosing-block *blocks*) (when (eq enclosing-block tag-block) (return nil)) - (when (equal (block-name enclosing-block) '(UNWIND-PROTECT)) + (when (block-requires-non-local-exit-p enclosing-block) (return t))))) (when protected (setf (block-non-local-go-p tag-block) t)))) @@ -695,6 +695,9 @@ (defknown p1-progv (t) t) (defun p1-progv (form) ;; We've already checked argument count in PRECOMPILE-PROGV. + + ;; ### FIXME: we need to return a block here, so that + ;; (local) GO in p2 can restore the lastSpecialBinding environment (let ((new-form (rewrite-progv form))) (when (neq new-form form) (return-from p1-progv (p1 new-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 Sun May 3 04:07:28 2009 @@ -4540,10 +4540,8 @@ (dolist (enclosing-block *blocks*) (when (eq enclosing-block tag-block) (return nil)) - (let ((block-name (block-name enclosing-block))) - (when (or (equal block-name '(CATCH)) - (equal block-name '(UNWIND-PROTECT))) - (return t)))))) + (when (block-requires-non-local-exit-p enclosing-block) + (return t))))) (unless protected (dolist (block *blocks*) (if (eq block tag-block) @@ -4728,7 +4726,7 @@ (dolist (enclosing-block *blocks*) (when (eq enclosing-block block) (return nil)) - (when (equal (block-name enclosing-block) '(UNWIND-PROTECT)) + (when (block-requires-non-local-exit-p enclosing-block) (return t))))) (unless protected (unless (compiland-single-valued-p *current-compiland*) 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 May 3 04:07:28 2009 @@ -379,6 +379,16 @@ (t nil))) +(defknown block-requires-non-local-exit-p (t) boolean) +(defun block-requires-non-local-exit-p (object) + "A block which *always* requires a 'non-local-exit' is a block which +requires a transfer control exception to be thrown: e.g. Go and Return. + +Non-local exits are required by blocks which do more in their cleanup +than just restore the lastSpecialBinding (= dynamic environment). +" + (memq (block-name object) '(CATCH UNWIND-PROTECT))) + (defvar *blocks* ()) (defun find-block (name) From ehuelsmann at common-lisp.net Sun May 3 08:46:39 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 04:46:39 -0400 Subject: [armedbear-cvs] r11819 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 04:46:39 2009 New Revision: 11819 Log: Small refactoring: introduce a centralized definition of "enclosed by a block which associates extensive cleanup with a transfer of control exception". Also some reordering of functions in jvm.lisp. 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 May 3 04:46:39 2009 @@ -312,12 +312,7 @@ ;; local return anyway so that UNWIND-PROTECT can catch it and run ;; its cleanup forms. (dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*)) - (let ((protected - (dolist (enclosing-block *blocks*) - (when (eq enclosing-block block) - (return nil)) - (when (block-requires-non-local-exit-p enclosing-block) - (return t))))) + (let ((protected (enclosed-by-protected-block-p block))) (dformat t "p1-return-from protected = ~S~%" protected) (when protected (setf (block-non-local-return-p block) t)))) @@ -365,14 +360,8 @@ (let ((tag-block (tag-block tag))) (cond ((eq (tag-compiland tag) *current-compiland*) ;; Does the GO leave an enclosing UNWIND-PROTECT? - (let ((protected - (dolist (enclosing-block *blocks*) - (when (eq enclosing-block tag-block) - (return nil)) - (when (block-requires-non-local-exit-p enclosing-block) - (return t))))) - (when protected - (setf (block-non-local-go-p tag-block) t)))) + (when (enclosed-by-protected-block-p tag-block) + (setf (block-non-local-go-p tag-block) t))) (t (setf (block-non-local-go-p tag-block) t))))) 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 Sun May 3 04:46:39 2009 @@ -4438,12 +4438,6 @@ (process-optimization-declarations body) (compile-progn-body body target representation)))) -(defknown find-tag (t) t) -(defun find-tag (name) - (dolist (tag *visible-tags*) - (when (eql name (tag-name tag)) - (return tag)))) - (defknown p2-tagbody-node (t t) t) (defun p2-tagbody-node (block target) (let* ((*blocks* (cons block *blocks*)) @@ -4534,15 +4528,8 @@ (when (eq (tag-compiland tag) *current-compiland*) ;; Local case. (let* ((tag-block (tag-block tag)) - (register nil) - (protected - ;; Does the GO leave an enclosing CATCH or UNWIND-PROTECT? - (dolist (enclosing-block *blocks*) - (when (eq enclosing-block tag-block) - (return nil)) - (when (block-requires-non-local-exit-p enclosing-block) - (return t))))) - (unless protected + (register nil)) + (unless (enclosed-by-protected-block-p tag-block) (dolist (block *blocks*) (if (eq block tag-block) (return) @@ -4722,20 +4709,14 @@ (when (eq (block-compiland block) compiland) ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which is ;; inside the block we're returning from? - (let ((protected - (dolist (enclosing-block *blocks*) - (when (eq enclosing-block block) - (return nil)) - (when (block-requires-non-local-exit-p enclosing-block) - (return t))))) - (unless protected - (unless (compiland-single-valued-p *current-compiland*) + (unless (enclosed-by-protected-block-p block) + (unless (compiland-single-valued-p *current-compiland*) ;; (format t "compiland not single-valued: ~S~%" ;; (compiland-name *current-compiland*)) - (emit-clear-values)) - (compile-form result-form (block-target block) nil) - (emit 'goto (block-exit block)) - (return-from p2-return-from))))) + (emit-clear-values)) + (compile-form result-form (block-target block) nil) + (emit 'goto (block-exit block)) + (return-from p2-return-from)))) ;; Non-local RETURN. (aver (block-non-local-return-p block)) (cond ((node-constant-p result-form) 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 May 3 04:46:39 2009 @@ -368,6 +368,13 @@ free-specials ) +(defvar *blocks* ()) + +(defun find-block (name) + (dolist (block *blocks*) + (when (eq name (block-name block)) + (return block)))) + (defknown node-constant-p (t) boolean) (defun node-constant-p (object) (cond ((block-node-p object) @@ -389,12 +396,19 @@ " (memq (block-name object) '(CATCH UNWIND-PROTECT))) -(defvar *blocks* ()) -(defun find-block (name) - (dolist (block *blocks*) - (when (eq name (block-name block)) - (return block)))) +(defknown enclosed-by-protected-block-p (&optional outermost-block) boolean) +(defun enclosed-by-protected-block-p (&optional outermost-block) + "Indicates whether the code being compiled/analyzed is enclosed in +a block which requires a non-local transfer of control exception to +be generated. +" + (dolist (enclosing-block *blocks*) + (when (eq enclosing-block outermost-block) + (return-from enclosed-by-protected-block-p nil)) + (when (block-requires-non-local-exit-p enclosing-block) + (return-from enclosed-by-protected-block-p t)))) + (defstruct tag name @@ -402,6 +416,12 @@ block (compiland *current-compiland*)) +(defknown find-tag (t) t) +(defun find-tag (name) + (dolist (tag *visible-tags*) + (when (eql name (tag-name tag)) + (return tag)))) + (defun process-ignore/ignorable (declaration names variables) (when (memq declaration '(IGNORE IGNORABLE)) (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable"))) From ehuelsmann at common-lisp.net Sun May 3 10:10:24 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 06:10:24 -0400 Subject: [armedbear-cvs] r11820 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 06:10:21 2009 New Revision: 11820 Log: Make local GO restore the environment of the TAGBODY, in case it jumps out of blocks setting the environment. 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 May 3 06:10:21 2009 @@ -360,8 +360,13 @@ (let ((tag-block (tag-block tag))) (cond ((eq (tag-compiland tag) *current-compiland*) ;; Does the GO leave an enclosing UNWIND-PROTECT? - (when (enclosed-by-protected-block-p tag-block) - (setf (block-non-local-go-p tag-block) t))) + (if (enclosed-by-protected-block-p tag-block) + (setf (block-non-local-go-p tag-block) t) + ;; non-local GO's ensure environment restoration + ;; find out about this local GO + (when (null (block-needs-environment-restoration tag-block)) + (setf (block-needs-environment-restoration tag-block) + (enclosed-by-environment-setting-block-p tag-block))))) (t (setf (block-non-local-go-p tag-block) t))))) 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 Sun May 3 06:10:21 2009 @@ -4449,13 +4449,32 @@ (BEGIN-BLOCK (gensym)) (END-BLOCK (gensym)) (EXIT (gensym)) - (must-clear-values nil)) + (must-clear-values nil) + environment-register) + (when (block-needs-environment-restoration block) + (setf environment-register (allocate-register) + (block-environment-register block) environment-register)) ;; Scan for tags. (dolist (subform body) (when (or (symbolp subform) (integerp subform)) (let* ((tag (make-tag :name subform :label (gensym) :block block))) (push tag local-tags) (push tag *visible-tags*)))) + + (when environment-register + ;; Note: we store the environment register, + ;; but since we don't manipulate the environment, + ;; we don't need to restore. + ;; + ;; It's here so local transfers of control can restore + ;; what we started with. + ;; + ;; Non-local transfers of control restore the environment + ;; themselves (in the finally of LET/LET*, etc. + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+) + (astore environment-register)) (label BEGIN-BLOCK) (do* ((rest body (cdr rest)) (subform (car rest) (car rest))) @@ -4522,27 +4541,23 @@ ;; FIXME What if we're called with a non-NIL representation? (declare (ignore representation)) (let* ((name (cadr form)) - (tag (find-tag name))) + (tag (find-tag name)) + (tag-block (when tag (tag-block tag)))) (unless tag (error "p2-go: tag not found: ~S" name)) - (when (eq (tag-compiland tag) *current-compiland*) - ;; Local case. - (let* ((tag-block (tag-block tag)) - (register nil)) - (unless (enclosed-by-protected-block-p tag-block) - (dolist (block *blocks*) - (if (eq block tag-block) - (return) - (setf register (or (block-environment-register block) register)))) - (when register - ;; Restore dynamic environment. - (aload *thread*) - (aload register) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+)) - (maybe-generate-interrupt-check) - (emit 'goto (tag-label tag)) - (return-from p2-go)))) + (when (and (eq (tag-compiland tag) *current-compiland*) + (not (enclosed-by-protected-block-p tag-block))) + ;; Local case with local transfer of control + ;; Note: Local case with non-local transfer of control handled below + (when (block-environment-register tag-block) + ;; If there's a dynamic environment to restore, do it. + (aload *thread*) + (aload (block-environment-register tag-block)) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+)) + (maybe-generate-interrupt-check) + (emit 'goto (tag-label tag)) + (return-from p2-go)) ;; Non-local GO. (emit 'new +lisp-go-class+) (emit 'dup) 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 May 3 06:10:21 2009 @@ -361,6 +361,9 @@ non-local-return-p ;; True if a tag in this tagbody is the target of a non-local GO. non-local-go-p + ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the + ;; environment, with GO forms in them which target tags in this TAGBODY + needs-environment-restoration ;; If non-nil, register containing saved dynamic environment for this block. environment-register ;; Only used in LET/LET*/M-V-B nodes. @@ -409,6 +412,14 @@ (when (block-requires-non-local-exit-p enclosing-block) (return-from enclosed-by-protected-block-p t)))) +(defknown enclosed-by-environment-setting-block-p (&optional outermost-block) + boolean) +(defun enclosed-by-environment-setting-block-p (&optional outermost-block) + (dolist (enclosing-block *blocks*) + (when (eq enclosing-block outermost-block) + (return nil)) + (when (block-environment-register enclosing-block) + (return t)))) (defstruct tag name From ehuelsmann at common-lisp.net Sun May 3 12:19:23 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 08:19:23 -0400 Subject: [armedbear-cvs] r11821 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 08:19:19 2009 New Revision: 11821 Log: Be more exact on determining 'being enclosed by a block which sets (= modifies) the environment'. 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 May 3 08:19:19 2009 @@ -363,6 +363,7 @@ non-local-go-p ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the ;; environment, with GO forms in them which target tags in this TAGBODY + ;; Non-nil if and only if the block doesn't modify the environment needs-environment-restoration ;; If non-nil, register containing saved dynamic environment for this block. environment-register @@ -400,7 +401,7 @@ (memq (block-name object) '(CATCH UNWIND-PROTECT))) -(defknown enclosed-by-protected-block-p (&optional outermost-block) boolean) +(defknown enclosed-by-protected-block-p (&optional t) boolean) (defun enclosed-by-protected-block-p (&optional outermost-block) "Indicates whether the code being compiled/analyzed is enclosed in a block which requires a non-local transfer of control exception to @@ -412,13 +413,13 @@ (when (block-requires-non-local-exit-p enclosing-block) (return-from enclosed-by-protected-block-p t)))) -(defknown enclosed-by-environment-setting-block-p (&optional outermost-block) - boolean) +(defknown enclosed-by-environment-setting-block-p (&optional t) boolean) (defun enclosed-by-environment-setting-block-p (&optional outermost-block) (dolist (enclosing-block *blocks*) (when (eq enclosing-block outermost-block) (return nil)) - (when (block-environment-register enclosing-block) + (when (and (block-environment-register enclosing-block) + (not (block-needs-environment-restoration enclosing-block))) (return t)))) (defstruct tag From ehuelsmann at common-lisp.net Sun May 3 13:03:48 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 09:03:48 -0400 Subject: [armedbear-cvs] r11822 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 09:03:48 2009 New Revision: 11822 Log: Followup to r11818: Fix block-requires-non-local-exit-p. 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 May 3 09:03:48 2009 @@ -398,7 +398,9 @@ Non-local exits are required by blocks which do more in their cleanup than just restore the lastSpecialBinding (= dynamic environment). " - (memq (block-name object) '(CATCH UNWIND-PROTECT))) + (let ((name (block-name object))) + (or (equal name '(CATCH)) + (equal name '(UNWIND-PROTECT))))) (defknown enclosed-by-protected-block-p (&optional t) boolean) From ehuelsmann at common-lisp.net Sun May 3 19:01:55 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 15:01:55 -0400 Subject: [armedbear-cvs] r11823 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 15:01:53 2009 New Revision: 11823 Log: Revert r11814 (fix for stack inconsistencies), because it breaks in other horrible ways. 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 May 3 15:01:53 2009 @@ -7871,10 +7871,12 @@ (exception-register (allocate-register)) (result-register (allocate-register)) (values-register (allocate-register)) + (return-address-register (allocate-register)) (BEGIN-PROTECTED-RANGE (gensym)) (END-PROTECTED-RANGE (gensym)) (HANDLER (gensym)) - (EXIT (gensym))) + (EXIT (gensym)) + (CLEANUP (gensym))) ;; Make sure there are no leftover multiple return values from previous calls. (emit-clear-values) @@ -7886,17 +7888,21 @@ (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) (astore values-register)) (label END-PROTECTED-RANGE)) - (dolist (subform cleanup-forms) - (compile-form subform nil nil)) + (emit 'jsr CLEANUP) (emit 'goto EXIT) ; Jump over handler. (label HANDLER) ; Start of exception handler. ;; The Throwable object is on the runtime stack. Stack depth is 1. (astore exception-register) - (dolist (subform cleanup-forms) - (compile-form subform nil nil)) + (emit 'jsr CLEANUP) ; Call cleanup forms. (maybe-emit-clear-values cleanup-forms) (aload exception-register) (emit 'athrow) ; Re-throw exception. + (label CLEANUP) ; Cleanup forms. + ;; Return address is on stack here. + (astore return-address-register) + (dolist (subform cleanup-forms) + (compile-form subform nil nil)) + (emit 'ret return-address-register) (label EXIT) ;; Restore multiple values returned by protected form. (unless (single-valued-p protected-form) From vvoutilainen at common-lisp.net Sun May 3 19:27:27 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 03 May 2009 15:27:27 -0400 Subject: [armedbear-cvs] r11824 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun May 3 15:27:26 2009 New Revision: 11824 Log: Get rid of Primitive[012]R, we don't truly need it. Also increment fasl-version, because this removes three classes and thus fasls become incompatible. Removed: trunk/abcl/src/org/armedbear/lisp/Primitive0R.java trunk/abcl/src/org/armedbear/lisp/Primitive1R.java trunk/abcl/src/org/armedbear/lisp/Primitive2R.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sun May 3 15:27:26 2009 @@ -341,7 +341,7 @@ // ### *fasl-version* // internal symbol private static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(29)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(30)); // ### *fasl-anonymous-package* // internal symbol 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 May 3 15:27:26 2009 @@ -1826,21 +1826,6 @@ (emit-constructor-lambda-name lambda-name) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 2))) - ((equal super "org/armedbear/lisp/Primitive0R") - (emit-constructor-lambda-name lambda-name) - (push '&REST args) - (emit-constructor-lambda-list args) - (emit-invokespecial-init super (lisp-object-arg-types 2))) - ((equal super "org/armedbear/lisp/Primitive1R") - (emit-constructor-lambda-name lambda-name) - (setf args (list (first args) '&REST (second args))) - (emit-constructor-lambda-list args) - (emit-invokespecial-init super (lisp-object-arg-types 2))) - ((equal super "org/armedbear/lisp/Primitive2R") - (emit-constructor-lambda-name lambda-name) - (setf args (list (first args) (second args) '&REST (third args))) - (emit-constructor-lambda-list args) - (emit-invokespecial-init super (lisp-object-arg-types 2))) ((equal super +lisp-ctf-class+) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 1))) @@ -8183,39 +8168,6 @@ (label-END (gensym)) (label-EXIT (gensym))) - (unless *child-p* - (when (memq '&REST args) - (unless (or (memq '&OPTIONAL args) (memq '&KEY args)) - (let ((arg-count (length args))) - (when - (cond ((and (= arg-count 2) (eq (%car args) '&REST)) - (setf descriptor (get-descriptor - (lisp-object-arg-types 1) - +lisp-object+) - super "org/armedbear/lisp/Primitive0R" - args (cdr args))) - ((and (= arg-count 3) (eq (%cadr args) '&REST)) - (setf descriptor (get-descriptor - (lisp-object-arg-types 2) - +lisp-object+) - super "org/armedbear/lisp/Primitive1R" - args (list (first args) (third args)))) - ((and (= arg-count 4) (eq (%caddr args) '&REST)) - (setf descriptor (get-descriptor - (list +lisp-object+ - +lisp-object+ +lisp-object+) - +lisp-object+) - super "org/armedbear/lisp/Primitive2R" - args (list (first args) - (second args) (fourth args))))) - (setf *using-arg-array* nil - *hairy-arglist-p* nil - (compiland-kind compiland) :internal - execute-method-name "_execute" - execute-method (make-method - :name execute-method-name - :descriptor descriptor))))))) - (dolist (var (compiland-arg-vars compiland)) (push var *visible-variables*)) From ehuelsmann at common-lisp.net Sun May 3 19:50:22 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 15:50:22 -0400 Subject: [armedbear-cvs] r11825 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 15:50:20 2009 New Revision: 11825 Log: Compilation P1: * Set up a CATCH block before processing the subforms. * Exclude the unwinding forms from the UNWIND-PROTECT block: they are themselves not protected by their own block. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun May 3 15:50:20 2009 @@ -272,6 +272,10 @@ (defun p1-catch (form) (let* ((tag (p1 (cadr form))) (body (cddr form)) + (block (make-block-node '(CATCH))) + ;; our subform processors need to know + ;; they're enclosed in a CATCH block + (*blocks* (cons block *blocks*)) (result '())) (dolist (subform body) (let ((op (and (consp subform) (%car subform)))) @@ -285,16 +289,22 @@ (return-from p1-catch (car result))) (push tag result) (push 'CATCH result) - (let ((block (make-block-node '(CATCH)))) - (setf (block-form block) result) - block))) + (setf (block-form block) result) + block)) (defun p1-unwind-protect (form) (if (= (length form) 2) (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...) (let* ((block (make-block-node '(UNWIND-PROTECT))) - (*blocks* (cons block *blocks*))) - (setf (block-form block) (p1-default form)) + ;; a bit of jumping through hoops... + (unprotected-forms (p1-body (cddr form))) + ;; ... because only the protected form is + ;; protected by the UNWIND-PROTECT block + (*blocks* (cons block *blocks*)) + (protected-form (p1 (cadr form)))) + (setf (block-form block) + `(unwind-protect ,protected-form + , at unprotected-forms)) block))) (defknown p1-return-from (t) t) From ehuelsmann at common-lisp.net Sun May 3 20:12:09 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 16:12:09 -0400 Subject: [armedbear-cvs] r11826 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 16:12:08 2009 New Revision: 11826 Log: Add documentation to the fields in the TAG structure. 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 May 3 16:12:08 2009 @@ -425,8 +425,11 @@ (return t)))) (defstruct tag + ;; The symbol (or integer) naming the tag name + ;; The symbol which is the jump target in JVM byte code label + ;; The associated TAGBODY block (compiland *current-compiland*)) From ehuelsmann at common-lisp.net Sun May 3 21:00:29 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 17:00:29 -0400 Subject: [armedbear-cvs] r11827 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 17:00:28 2009 New Revision: 11827 Log: P2-CATCH: Do what we do in P1-CATCH, which is binding the CATCH block during compilation of the body. 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 May 3 17:00:28 2009 @@ -7792,11 +7792,12 @@ (aload tag-register) (emit-invokevirtual +lisp-thread-class+ "pushCatchTag" (lisp-object-arg-types 1) nil) - ; Stack depth is 0. - (label BEGIN-PROTECTED-RANGE) ; Start of protected range. - (compile-progn-body (cddr form) target) ; Implicit PROGN. - (label END-PROTECTED-RANGE) ; End of protected range. - (emit 'goto EXIT) ; Jump over handlers. + (let ((*blocks* (cons block *blocks*))) + ; Stack depth is 0. + (label BEGIN-PROTECTED-RANGE) ; Start of protected range. + (compile-progn-body (cddr form) target) ; Implicit PROGN. + (label END-PROTECTED-RANGE) ; End of protected range. + (emit 'goto EXIT)) ; Jump over handlers. (label THROW-HANDLER) ; Start of handler for THROW. ;; The Throw object is on the runtime stack. Stack depth is 1. (emit 'dup) ; Stack depth is 2. From ehuelsmann at common-lisp.net Sun May 3 21:43:09 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 May 2009 17:43:09 -0400 Subject: [armedbear-cvs] r11828 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 3 17:43:08 2009 New Revision: 11828 Log: Use the fact that tags have lexical scope: if they're not used, don't generate comparisons for tags which are not used. * P1: Find out which tags are used * P2: Limit the number of tag comparisons 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 May 3 17:43:08 2009 @@ -336,17 +336,21 @@ (let* ((block (make-block-node '(TAGBODY))) (*blocks* (cons block *blocks*)) (*visible-tags* *visible-tags*) + (local-tags '()) (body (cdr form))) ;; Make all the tags visible before processing the body forms. (dolist (subform body) (when (or (symbolp subform) (integerp subform)) (let* ((tag (make-tag :name subform :label (gensym) :block block))) + (push tag local-tags) (push tag *visible-tags*)))) (let ((new-body '()) (live t)) (dolist (subform body) (cond ((or (symbolp subform) (integerp subform)) (push subform new-body) + (push (find subform local-tags :key #'tag-name :test #'eql) + (block-tags block)) (setf live t)) ((not live) ;; Nothing to do. @@ -367,6 +371,7 @@ (tag (find-tag name))) (unless tag (error "p1-go: tag not found: ~S" name)) + (setf (tag-used tag) t) (let ((tag-block (tag-block tag))) (cond ((eq (tag-compiland tag) *current-compiland*) ;; Does the GO leave an enclosing UNWIND-PROTECT? 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 May 3 17:43:08 2009 @@ -4430,7 +4430,6 @@ (*register* *register*) (form (block-form block)) (body (cdr form)) - (local-tags ()) (BEGIN-BLOCK (gensym)) (END-BLOCK (gensym)) (EXIT (gensym)) @@ -4440,11 +4439,8 @@ (setf environment-register (allocate-register) (block-environment-register block) environment-register)) ;; Scan for tags. - (dolist (subform body) - (when (or (symbolp subform) (integerp subform)) - (let* ((tag (make-tag :name subform :label (gensym) :block block))) - (push tag local-tags) - (push tag *visible-tags*)))) + (dolist (tag (block-tags block)) + (push tag *visible-tags*)) (when environment-register ;; Note: we store the environment register, @@ -4465,10 +4461,12 @@ (subform (car rest) (car rest))) ((null rest)) (cond ((or (symbolp subform) (integerp subform)) - (let ((tag (find-tag subform))) + (let ((tag (find subform (block-tags block) :key #'tag-name + :test #'eql))) (unless tag (error "COMPILE-TAGBODY: tag not found: ~S~%" subform)) - (label (tag-label tag)))) + (when (tag-used tag) + (label (tag-label tag))))) (t (compile-form subform nil nil) (unless must-clear-values @@ -4492,7 +4490,9 @@ (emit 'checkcast +lisp-go-class+) (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1. (astore tag-register) - (dolist (tag local-tags) + ;; Don't actually generate comparisons for tags + ;; to which there is no GO instruction + (dolist (tag (remove-if-not #'tag-used (block-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 Sun May 3 17:43:08 2009 @@ -370,6 +370,8 @@ ;; Only used in LET/LET*/M-V-B nodes. vars free-specials + ;; Only used in TAGBODY + tags ) (defvar *blocks* ()) @@ -431,7 +433,8 @@ label ;; The associated TAGBODY block - (compiland *current-compiland*)) + (compiland *current-compiland*) + used) (defknown find-tag (t) t) (defun find-tag (name) From ehuelsmann at common-lisp.net Mon May 4 19:43:35 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 04 May 2009 15:43:35 -0400 Subject: [armedbear-cvs] r11829 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 4 15:43:30 2009 New Revision: 11829 Log: Simplify p1-compiland and p2-compiland. Create a new 'free-specials' field in the compiland structure to share work done in p1 with p2. 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 May 4 15:43:30 2009 @@ -1020,24 +1020,23 @@ (process-optimization-declarations (cddr form)) (let* ((lambda-list (cadr form)) - (body (cddr form))) - - (let* ((closure (make-closure `(lambda ,lambda-list nil) nil)) - (syms (sys::varlist closure)) - (vars nil)) - (dolist (sym syms) - (let ((var (make-variable :name sym - :special-p (special-variable-p sym)))) - (push var vars) - (push var *all-variables*))) - (setf (compiland-arg-vars compiland) (nreverse vars)) - (let ((*visible-variables* *visible-variables*)) - (dolist (var (compiland-arg-vars compiland)) - (push var *visible-variables*)) - (let ((free-specials (process-declarations-for-vars body *visible-variables*))) - (dolist (var free-specials) - (push var *visible-variables*))) - (setf (compiland-p1-result compiland) - (list* 'LAMBDA lambda-list (p1-body body)))))))) + (body (cddr form)) + (*visible-variables* *visible-variables*) + (closure (make-closure `(lambda ,lambda-list nil) nil)) + (syms (sys::varlist closure)) + (vars nil)) + (dolist (sym syms) + (let ((var (make-variable :name sym + :special-p (special-variable-p sym)))) + (push var vars) + (push var *all-variables*) + (push var *visible-variables*))) + (setf (compiland-arg-vars compiland) (nreverse vars)) + (let ((free-specials (process-declarations-for-vars body vars))) + (setf (compiland-free-specials compiland) free-specials) + (dolist (var free-specials) + (push var *visible-variables*))) + (setf (compiland-p1-result compiland) + (list* 'LAMBDA lambda-list (p1-body body)))))) (provide "COMPILER-PASS1") \ No newline at end of file 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 May 4 15:43:30 2009 @@ -8160,8 +8160,6 @@ (*handlers* ()) (*visible-variables* *visible-variables*) - (parameters ()) - (*thread* nil) (*initialize-thread-var* nil) (super nil) @@ -8171,54 +8169,34 @@ (dolist (var (compiland-arg-vars compiland)) (push var *visible-variables*)) + (dolist (var (compiland-free-specials compiland)) + (push var *visible-variables*)) (setf (method-name-index execute-method) (pool-name (method-name execute-method))) (setf (method-descriptor-index execute-method) (pool-name (method-descriptor execute-method))) (cond (*hairy-arglist-p* - (let* ((closure (make-closure p1-result nil)) - (parameter-names (sys::varlist closure)) - (index 0)) - (dolist (name parameter-names) - (let ((variable (find-visible-variable name))) - (unless variable - (format t "1: unable to find variable ~S~%" name) - (aver nil)) - (aver (null (variable-register variable))) - (aver (null (variable-index variable))) - (setf (variable-index variable) index) - (push variable parameters) - (incf index))))) + (let ((index 0)) + (dolist (variable (compiland-arg-vars compiland)) + (aver (null (variable-register variable))) + (aver (null (variable-index variable))) + (setf (variable-index variable) index) + (incf index)))) (t (let ((register (if (and *closure-variables* *child-p*) 2 ; Reg 1 is reserved for closure variables array. 1)) (index 0)) - (dolist (arg args) - (let ((variable (find-visible-variable arg))) - (when (null variable) - (format t "2: unable to find variable ~S~%" arg) - (aver nil)) - (aver (null (variable-register variable))) - (setf (variable-register variable) (if *using-arg-array* nil register)) - (aver (null (variable-index variable))) - (if *using-arg-array* - (setf (variable-index variable) index)) - (push variable parameters) - (incf register) - (incf index)))))) - - (let ((specials (process-special-declarations body))) - (dolist (name specials) - (dformat t "recognizing ~S as special~%" name) - (let ((variable (find-visible-variable name))) - (cond ((null variable) - (setf variable (make-variable :name name - :special-p t)) - (push variable *visible-variables*)) - (t - (setf (variable-special-p variable) t)))))) + (dolist (variable (compiland-arg-vars compiland)) + (aver (null (variable-register variable))) + (setf (variable-register variable) + (if *using-arg-array* nil register)) + (aver (null (variable-index variable))) + (if *using-arg-array* + (setf (variable-index variable) index)) + (incf register) + (incf index))))) (p2-compiland-process-type-declarations body) @@ -8232,15 +8210,15 @@ (unless (or *closure-variables* *child-p*) ;; Reserve a register for each parameter. - (dolist (variable (reverse parameters)) + (dolist (variable (compiland-arg-vars compiland)) (aver (null (variable-register variable))) (aver (null (variable-reserved-register variable))) (unless (variable-special-p variable) (setf (variable-reserved-register variable) (allocate-register)))))) (t ;; Otherwise, one register for each argument. - (dolist (arg args) - (declare (ignore arg)) + (dolist (variable (compiland-arg-vars compiland)) + (declare (ignore variable)) (allocate-register)))) (when (and *closure-variables* (not *child-p*)) (setf (compiland-closure-register compiland) (allocate-register)) @@ -8255,13 +8233,14 @@ (compiland-name compiland)) (cond (*child-p* (aver (eql (compiland-closure-register compiland) 1)) - (when (some #'variable-closure-index parameters) + (when (some #'variable-closure-index + (compiland-arg-vars compiland)) (aload (compiland-closure-register compiland)))) (t (emit-push-constant-int (length *closure-variables*)) (dformat t "p2-compiland ~S anewarray 1~%" (compiland-name compiland)) (emit 'anewarray "org/armedbear/lisp/LispObject"))) - (dolist (variable parameters) + (dolist (variable (compiland-arg-vars compiland)) (dformat t "considering ~S ...~%" (variable-name variable)) (when (variable-closure-index variable) (dformat t "moving variable ~S~%" (variable-name variable)) @@ -8287,7 +8266,8 @@ (setf (variable-index variable) nil))))) ; The variable has moved. (aver (not (null (compiland-closure-register compiland)))) (cond (*child-p* - (when (some #'variable-closure-index parameters) + (when (some #'variable-closure-index + (compiland-arg-vars compiland)) (emit 'pop))) (t (astore (compiland-closure-register compiland)))) @@ -8297,7 +8277,7 @@ ;; If applicable, move args from arg array to registers. (when *using-arg-array* (unless (or *closure-variables* *child-p*) - (dolist (variable (reverse parameters)) + (dolist (variable (compiland-arg-vars compiland)) (when (variable-reserved-register variable) (aver (not (variable-special-p variable))) (aload (compiland-argument-register compiland)) @@ -8307,14 +8287,14 @@ (setf (variable-register variable) (variable-reserved-register variable)) (setf (variable-index variable) nil))))) - (generate-type-checks-for-variables (reverse parameters)) + (generate-type-checks-for-variables (compiland-arg-vars compiland)) ;; Unbox variables. - (dolist (variable (reverse parameters)) + (dolist (variable (compiland-arg-vars compiland)) (p2-compiland-unbox-variable variable)) ;; Establish dynamic bindings for any variables declared special. - (when (some #'variable-special-p parameters) + (when (some #'variable-special-p (compiland-arg-vars compiland)) ;; Save the dynamic environment (setf (compiland-environment-register compiland) (allocate-register)) @@ -8322,25 +8302,25 @@ (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) (astore (compiland-environment-register compiland)) - (label label-START)) - (dolist (variable parameters) - (when (variable-special-p variable) - (cond ((variable-register variable) - (emit-push-current-thread) - (emit-push-variable-name variable) - (aload (variable-register variable)) - (emit-invokevirtual +lisp-thread-class+ "bindSpecial" - (list +lisp-symbol+ +lisp-object+) nil) - (setf (variable-register variable) nil)) - ((variable-index variable) - (emit-push-current-thread) - (emit-push-variable-name variable) - (aload (compiland-argument-register compiland)) - (emit-push-constant-int (variable-index variable)) - (emit 'aaload) - (emit-invokevirtual +lisp-thread-class+ "bindSpecial" - (list +lisp-symbol+ +lisp-object+) nil) - (setf (variable-index variable) nil))))) + (label label-START) + (dolist (variable (compiland-arg-vars compiland)) + (when (variable-special-p variable) + (cond ((variable-register variable) + (emit-push-current-thread) + (emit-push-variable-name variable) + (aload (variable-register variable)) + (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (list +lisp-symbol+ +lisp-object+) nil) + (setf (variable-register variable) nil)) + ((variable-index variable) + (emit-push-current-thread) + (emit-push-variable-name variable) + (aload (compiland-argument-register compiland)) + (emit-push-constant-int (variable-index variable)) + (emit 'aaload) + (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (list +lisp-symbol+ +lisp-object+) nil) + (setf (variable-index variable) nil)))))) (compile-progn-body body 'stack) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Mon May 4 15:43:30 2009 @@ -156,6 +156,7 @@ (kind :external) ; :INTERNAL or :EXTERNAL lambda-expression arg-vars + free-specials arity ; NIL if the number of args can vary. p1-result parent From ehuelsmann at common-lisp.net Mon May 4 21:07:23 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 04 May 2009 17:07:23 -0400 Subject: [armedbear-cvs] r11830 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 4 17:07:23 2009 New Revision: 11830 Log: Make free specials visible in p2-locally and p2-m-v-b. 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 Mon May 4 17:07:23 2009 @@ -4033,6 +4033,8 @@ ;; Make the variables visible for the body forms. (dolist (variable variables) (push variable *visible-variables*)) + (dolist (variable (block-free-specials block)) + (push variable *visible-variables*)) ;; Body. (compile-progn-body (cdddr form) target) (when bind-special-p @@ -4419,7 +4421,11 @@ (defun p2-locally (form target representation) (with-saved-compiler-policy - (let ((body (cdr form))) + (let* ((body (cdr form)) + (*visible-variables* *visible-variables*) + (specials (process-special-declarations body))) + (dolist (name specials) + (push (make-variable :name name :special-p t) *visible-variables*)) (process-optimization-declarations body) (compile-progn-body body target representation)))) From ehuelsmann at common-lisp.net Tue May 5 06:36:05 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 05 May 2009 02:36:05 -0400 Subject: [armedbear-cvs] r11831 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 5 02:36:02 2009 New Revision: 11831 Log: P2: Parse and publicize free specials in FLET/LABELS bodies Precompile: Make sure declarations in trimmed FLET/LABELS bodies don't get ignored Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue May 5 02:36:02 2009 @@ -5020,6 +5020,9 @@ (let ((variable (local-function-variable local-function))) (when variable (push variable *visible-variables*)))) + (dolist (special (process-special-declarations body)) + (push (make-variable :name special :special-p t) + *visible-variables*)) (do ((forms body (cdr forms))) ((null forms)) (compile-form (car forms) (if (cdr forms) nil target) nil)))) @@ -5040,6 +5043,9 @@ (setf (variable-register variable) (allocate-register))))) (dolist (local-function local-functions) (p2-labels-process-compiland local-function)) + (dolist (special (process-special-declarations body)) + (push (make-variable :name special :special-p t) + *visible-variables*)) (do ((forms body (cdr forms))) ((null forms)) (compile-form (car forms) (if (cdr forms) nil 'stack) nil)) Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Tue May 5 02:36:02 2009 @@ -789,7 +789,7 @@ (new-form (if new-locals (list* operator new-locals body) - (list* 'PROGN body)))) + (list* 'LOCALLY body)))) (return-from precompile-flet/labels (precompile1 new-form)))))) (list* (car form) (precompile-local-functions locals) From vvoutilainen at common-lisp.net Tue May 5 17:22:36 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 05 May 2009 13:22:36 -0400 Subject: [armedbear-cvs] r11832 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Tue May 5 13:22:31 2009 New Revision: 11832 Log: Cleanup for saving/restoring dynamic environment. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue May 5 13:22:31 2009 @@ -3952,6 +3952,18 @@ (setq tail (cdr tail))))))) t) +(defun restore-dynamic-environment (register) + (emit-push-current-thread) + (aload register) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+)) + +(defun save-dynamic-environment (register) + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" + +lisp-special-binding+) + (astore register)) + (defun p2-m-v-b-node (block target) (let* ((*blocks* (cons block *blocks*)) (*register* *register*) @@ -3975,10 +3987,7 @@ (dformat t "p2-m-v-b-node lastSpecialBinding~%") ;; Save current dynamic environment. (setf (block-environment-register block) (allocate-register)) - (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) - (astore (block-environment-register block)) + (save-dynamic-environment (block-environment-register block)) (label label-START)) ;; Make sure there are no leftover values from previous calls. (emit-clear-values) @@ -4040,18 +4049,12 @@ (when bind-special-p (emit 'goto label-EXIT) (label label-END) - (aload *thread*) - (aload (block-environment-register block)) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) + (restore-dynamic-environment (block-environment-register block)) (emit 'athrow) ;; Restore dynamic environment. (label label-EXIT) - (aload *thread*) - (aload (block-environment-register block)) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) + (restore-dynamic-environment (block-environment-register block)) (push (make-handler :from label-START :to label-END :code label-END @@ -4380,10 +4383,7 @@ (when specialp ;; We need to save current dynamic environment. (setf (block-environment-register block) (allocate-register)) - (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) - (astore (block-environment-register block)) + (save-dynamic-environment (block-environment-register block)) (label label-START)) (propagate-vars block) (ecase (car form) @@ -4402,18 +4402,11 @@ (emit 'goto label-EXIT) (label label-END) ;; Restore dynamic environment. - (aload *thread*) - (aload (block-environment-register block)) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) + (restore-dynamic-environment (block-environment-register block)) (emit 'athrow) (label label-EXIT) - (aload *thread*) - (aload (block-environment-register block)) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) - + (restore-dynamic-environment (block-environment-register block)) (push (make-handler :from label-START :to label-END :code label-END @@ -4458,10 +4451,7 @@ ;; ;; Non-local transfers of control restore the environment ;; themselves (in the finally of LET/LET*, etc. - (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) - (astore environment-register)) + (save-dynamic-environment environment-register)) (label BEGIN-BLOCK) (do* ((rest body (cdr rest)) (subform (car rest) (car rest))) @@ -4542,10 +4532,7 @@ ;; Note: Local case with non-local transfer of control handled below (when (block-environment-register tag-block) ;; If there's a dynamic environment to restore, do it. - (aload *thread*) - (aload (block-environment-register tag-block)) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+)) + (restore-dynamic-environment (block-environment-register tag-block))) (maybe-generate-interrupt-check) (emit 'goto (tag-label tag)) (return-from p2-go)) @@ -4652,9 +4639,7 @@ (cond ((some #'variable-special-p *all-variables*) ;; Save the current dynamic environment. (setf (block-environment-register block) (allocate-register)) - (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) - (astore (block-environment-register block))) + (save-dynamic-environment (block-environment-register block))) (t (dformat t "no specials~%"))) (setf (block-catch-tag block) (gensym)) @@ -4693,9 +4678,7 @@ (label BLOCK-EXIT)) (when (block-environment-register block) ;; We saved the dynamic environment above. Restore it now. - (aload *thread*) - (aload (block-environment-register block)) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)) + (restore-dynamic-environment (block-environment-register block))) (fix-boxing representation nil) ) (t @@ -4815,31 +4798,22 @@ (unless (and (single-valued-p symbols-form) (single-valued-p values-form)) (emit-clear-values)) - (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) - (astore environment-register) + (save-dynamic-environment environment-register) (label label-START) ;; Compile call to Lisp.progvBindVars(). - (aload *thread*) + (emit-push-current-thread) (emit-invokestatic +lisp-class+ "progvBindVars" (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) ;; Implicit PROGN. (compile-progn-body (cdddr form) target) (emit 'goto label-EXIT) (label label-END) - (aload *thread*) - (aload environment-register) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) + (restore-dynamic-environment environment-register) (emit 'athrow) ;; Restore dynamic environment. (label label-EXIT) - (aload *thread*) - (aload environment-register) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) + (restore-dynamic-environment environment-register) (fix-boxing representation nil) (push (make-handler :from label-START :to label-END @@ -7818,19 +7792,19 @@ ;; If it's not the tag we're looking for, we branch to the start of the ;; catch-all handler, which will do a re-throw. (emit 'if_acmpne DEFAULT-HANDLER) ; Stack depth is 1. - (aload *thread*) + (emit-push-current-thread) (emit-invokevirtual +lisp-throw-class+ "getResult" (list +lisp-thread+) +lisp-object+) (emit-move-from-stack target) ; Stack depth is 0. (emit 'goto EXIT) (label DEFAULT-HANDLER) ; Start of handler for all other Throwables. ;; A Throwable object is on the runtime stack here. Stack depth is 1. - (aload *thread*) + (emit-push-current-thread) (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) (emit 'athrow) ; Re-throw. (label EXIT) ;; Finally... - (aload *thread*) + (emit-push-current-thread) (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) (let ((handler1 (make-handler :from BEGIN-PROTECTED-RANGE :to END-PROTECTED-RANGE @@ -8310,10 +8284,7 @@ ;; Save the dynamic environment (setf (compiland-environment-register compiland) (allocate-register)) - (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) - (astore (compiland-environment-register compiland)) + (save-dynamic-environment (compiland-environment-register compiland)) (label label-START) (dolist (variable (compiland-arg-vars compiland)) (when (variable-special-p variable) @@ -8339,19 +8310,12 @@ (when (compiland-environment-register compiland) (emit 'goto label-EXIT) (label label-END) - (emit-push-current-thread) - (aload (compiland-environment-register compiland)) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) + (restore-dynamic-environment (compiland-environment-register compiland)) (emit 'athrow) ;; Restore dynamic environment (label label-EXIT) - (emit-push-current-thread) - (aload (compiland-environment-register compiland)) - (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" - +lisp-special-binding+) - + (restore-dynamic-environment (compiland-environment-register compiland)) (push (make-handler :from label-START :to label-END :code label-END @@ -8378,7 +8342,7 @@ (cond ((or (memq '&OPTIONAL args) (memq '&KEY args)) (ensure-thread-var-initialized) (maybe-initialize-thread-var) - (aload *thread*) + (emit-push-current-thread) (emit-invokevirtual *this-class* "processArgs" (list +lisp-object-array+ +lisp-thread+) +lisp-object-array+)) From ehuelsmann at common-lisp.net Tue May 5 21:42:22 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 05 May 2009 17:42:22 -0400 Subject: [armedbear-cvs] r11833 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 5 17:42:17 2009 New Revision: 11833 Log: Special bindings fixes: compiler-pass1.lisp: set BLOCK-ENVIRONMENT-REGISTER to T, for ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P to find. p1-progv: correctness; the symbol and values forms are outside of the progv-block-scope p2-progv-node: from p2-progv. A node is required to indicate to code inside the PROGV scope that bindings restoration is in order p1-return-from: indicate to the associated block that a RETURN-FROM instruction will want to p2-block-node: p2-progv-node doesn't register variables, yet it does require a block restoration. Now that PROGV uses a block (with an environment-register!) it's incorrect to look at *all-variables*. ... and a little bit of re-indenting. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Tue May 5 17:42:17 2009 @@ -210,11 +210,13 @@ ;; Check for globally declared specials. (dolist (variable vars) (when (special-variable-p (variable-name variable)) - (setf (variable-special-p variable) t))) + (setf (variable-special-p variable) t + (block-environment-register block) t))) ;; For processing declarations, we want to walk the variable list from ;; last to first, since declarations apply to the last-defined variable ;; with the specified name. - (setf (block-free-specials block) (process-declarations-for-vars body (reverse vars))) + (setf (block-free-specials block) + (process-declarations-for-vars body (reverse vars))) (setf (block-vars block) vars) ;; Make free specials visible. (dolist (variable (block-free-specials block)) @@ -255,8 +257,10 @@ ;; Check for globally declared specials. (dolist (variable vars) (when (special-variable-p (variable-name variable)) - (setf (variable-special-p variable) t))) - (setf (block-free-specials block) (process-declarations-for-vars body vars)) + (setf (variable-special-p variable) t + (block-environment-register block) t))) + (setf (block-free-specials block) + (process-declarations-for-vars body vars)) (setf (block-vars block) (nreverse vars))) (setf body (p1-body body)) (setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body)) @@ -324,8 +328,13 @@ (dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*)) (let ((protected (enclosed-by-protected-block-p block))) (dformat t "p1-return-from protected = ~S~%" protected) - (when protected - (setf (block-non-local-return-p block) t)))) + (if protected + (setf (block-non-local-return-p block) t) + ;; non-local GO's ensure environment restoration + ;; find out about this local GO + (when (null (block-needs-environment-restoration block)) + (setf (block-needs-environment-restoration block) + (enclosed-by-environment-setting-block-p block)))))) (t (setf (block-non-local-return-p block) t))) (when (block-non-local-return-p block) @@ -374,7 +383,7 @@ (setf (tag-used tag) t) (let ((tag-block (tag-block tag))) (cond ((eq (tag-compiland tag) *current-compiland*) - ;; Does the GO leave an enclosing UNWIND-PROTECT? + ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH? (if (enclosed-by-protected-block-p tag-block) (setf (block-non-local-go-p tag-block) t) ;; non-local GO's ensure environment restoration @@ -710,10 +719,15 @@ (let ((new-form (rewrite-progv form))) (when (neq new-form form) (return-from p1-progv (p1 new-form)))) - (let ((symbols-form (cadr form)) - (values-form (caddr form)) - (body (cdddr form))) - `(progv ,(p1 symbols-form) ,(p1 values-form) ,@(p1-body body)))) + (let* ((symbols-form (p1 (cadr form))) + (values-form (p1 (caddr form))) + (block (make-block-node '(PROGV))) + (*blocks* (cons block *blocks*)) + (body (cdddr form))) + (setf (block-form block) + `(progv ,symbols-form ,values-form ,@(p1-body body)) + (block-environment-register block) t) + block)) (defknown rewrite-progv (t) t) (defun rewrite-progv (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 Tue May 5 17:42:17 2009 @@ -4635,13 +4635,12 @@ (cond ((block-return-p block) (setf (block-target block) target) (dformat t "p2-block-node lastSpecialBinding~%") - (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) - (cond ((some #'variable-special-p *all-variables*) - ;; Save the current dynamic environment. - (setf (block-environment-register block) (allocate-register)) - (save-dynamic-environment (block-environment-register block))) - (t - (dformat t "no specials~%"))) + (dformat t "*all-variables* = ~S~%" + (mapcar #'variable-name *all-variables*)) + (when (block-needs-environment-restoration block) + ;; Save the current dynamic environment. + (setf (block-environment-register block) (allocate-register)) + (save-dynamic-environment (block-environment-register block))) (setf (block-catch-tag block) (gensym)) (let* ((*register* *register*) (BEGIN-BLOCK (gensym)) @@ -4785,11 +4784,13 @@ (t (compile-constant (eval (second form)) target representation)))) -(defun p2-progv (form target representation) - (let* ((symbols-form (cadr form)) +(defun p2-progv-node (block target representation) + (let* ((form (block-form block)) + (symbols-form (cadr form)) (values-form (caddr form)) (*register* *register*) - (environment-register (allocate-register)) + (environment-register + (setf (block-environment-register block) (allocate-register))) (label-START (gensym)) (label-END (gensym)) (label-EXIT (gensym))) @@ -4804,12 +4805,13 @@ (emit-push-current-thread) (emit-invokestatic +lisp-class+ "progvBindVars" (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) - ;; Implicit PROGN. - (compile-progn-body (cdddr form) target) - (emit 'goto label-EXIT) - (label label-END) - (restore-dynamic-environment environment-register) - (emit 'athrow) + ;; Implicit PROGN. + (let ((*blocks* (cons block *blocks*))) + (compile-progn-body (cdddr form) target) + (emit 'goto label-EXIT) + (label label-END) + (restore-dynamic-environment environment-register) + (emit 'athrow)) ;; Restore dynamic environment. (label label-EXIT) @@ -7938,30 +7940,22 @@ ((block-node-p form) (cond ((equal (block-name form) '(TAGBODY)) (p2-tagbody-node form target) - (fix-boxing representation nil) - ) + (fix-boxing representation nil)) ((equal (block-name form) '(LET)) - (p2-let/let*-node form target representation) -;; (fix-boxing representation nil) - ) + (p2-let/let*-node form target representation)) ((equal (block-name form) '(MULTIPLE-VALUE-BIND)) (p2-m-v-b-node form target) - (fix-boxing representation nil) - ) + (fix-boxing representation nil)) ((equal (block-name form) '(UNWIND-PROTECT)) (p2-unwind-protect-node form target) - (fix-boxing representation nil) - ) + (fix-boxing representation nil)) ((equal (block-name form) '(CATCH)) (p2-catch-node form target) - (fix-boxing representation nil) - ) + (fix-boxing representation nil)) + ((equal (block-name form) '(PROGV)) + (p2-progv-node form target representation)) (t - (p2-block-node form target representation) -;; (fix-boxing representation nil) - )) -;; (fix-boxing representation nil) - ) + (p2-block-node form target representation)))) ((constantp form) (compile-constant form target representation)) (t @@ -8708,7 +8702,6 @@ (install-p2-handler 'null 'p2-not/null) (install-p2-handler 'or 'p2-or) (install-p2-handler 'packagep 'p2-packagep) - (install-p2-handler 'progv 'p2-progv) (install-p2-handler 'puthash 'p2-puthash) (install-p2-handler 'quote 'p2-quote) (install-p2-handler 'read-line 'p2-read-line) From astalla at common-lisp.net Tue May 5 22:01:52 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 05 May 2009 18:01:52 -0400 Subject: [armedbear-cvs] r11834 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue May 5 18:01:50 2009 New Revision: 11834 Log: Relaxed type checking when invoking Java methods from Lisp, as discussed on the mailing list. Modified: trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/LispObject.java Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Tue May 5 18:01:50 2009 @@ -625,10 +625,7 @@ else if (instanceArg instanceof JavaObject) instance = ((JavaObject)instanceArg).getObject(); else { - type_error(instanceArg, - list(Symbol.OR, Symbol.STRING, Symbol.JAVA_OBJECT)); - // Not reached. - return null; + instance = instanceArg.javaInstance(); } try { final Method method; 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 Tue May 5 18:01:50 2009 @@ -102,16 +102,14 @@ public Object javaInstance() throws ConditionThrowable { return this; - /*return error(new LispError("The value " + writeToString() + - " is not of primitive type."));*/ } public Object javaInstance(Class c) throws ConditionThrowable { - if (c == LispObject.class) - return this; - return error(new LispError("The value " + writeToString() + - " is not of primitive type.")); + if (getClass().isAssignableFrom(c)) + return this; + return error(new LispError("The value " + writeToString() + + " is not of class " + c.getName())); } public LispObject car() throws ConditionThrowable From vvoutilainen at common-lisp.net Wed May 6 18:34:44 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Wed, 06 May 2009 14:34:44 -0400 Subject: [armedbear-cvs] r11835 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Wed May 6 14:34:40 2009 New Revision: 11835 Log: Combine check-arg-count and check-min-args with a format recipe and an optional argument. Note, ansi tests do not exercise the failure case for check-min-args, but the format recipe is easy enough to test with the following snippet: (format t "Wrong number of arguments for ~A (expected~:[~; at least~] ~D, but received ~D)." 1 nil 2 3) By changing the second argument after the format string from nil to t, both cases can be seen to work with this format string. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed May 6 14:34:40 2009 @@ -1001,34 +1001,29 @@ ;; the value of a constant defined with DEFCONSTANT, calling built-in Lisp ;; functions with a wrong number of arguments or malformed keyword argument ;; lists, and using unrecognized declaration specifiers." (3.2.5) -(defknown check-arg-count (t fixnum) t) -(defun check-arg-count (form n) +(defun check-number-of-args (form n &optional (minimum nil)) (declare (type fixnum n)) (let* ((op (car form)) (args (cdr form)) - (ok (= (length args) n))) + (ok (if minimum + (>= (length args) n) + (= (length args) n)))) (declare (type boolean ok)) (unless ok (funcall (if (eq (symbol-package op) +cl-package+) #'compiler-warn ; See above! #'compiler-style-warn) - "Wrong number of arguments for ~A (expected ~D, but received ~D)." - op n (length args))) + "Wrong number of arguments for ~A (expected~:[~; at least~] ~D, but received ~D)." + op minimum n (length args))) ok)) +(defknown check-arg-count (t fixnum) t) +(defun check-arg-count (form n) + (check-number-of-args form n)) + (declaim (ftype (function (t fixnum) t) check-min-args)) (defun check-min-args (form n) - (declare (type fixnum n)) - (let* ((op (car form)) - (args (cdr form)) - (ok (>= (length args) n))) - (unless ok - (funcall (if (eq (symbol-package op) +cl-package+) - #'compiler-warn ; See above! - #'compiler-style-warn) - "Wrong number of arguments for ~A (expected at least ~D, but received ~D)." - op n (length args))) - ok)) + (check-number-of-args form n t)) (defun unsupported-opcode (instruction) (error "Unsupported opcode ~D." (instruction-opcode instruction))) From ehuelsmann at common-lisp.net Wed May 6 18:52:19 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 06 May 2009 14:52:19 -0400 Subject: [armedbear-cvs] r11836 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 6 14:52:17 2009 New Revision: 11836 Log: Support the #\Escape character. Patch by: Eric Marsden (eric marsden free fr) 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 Wed May 6 14:52:17 2009 @@ -250,6 +250,9 @@ case '\r': sb.append("Return"); break; + case 27: + sb.append("Escape"); + break; case 127: sb.append("Rubout"); break; @@ -554,6 +557,8 @@ return '\f'; if (lower.equals("return")) return '\r'; + if (lower.equals("escape")) + return 27; if (lower.equals("space")) return ' '; if (lower.equals("rubout")) @@ -593,6 +598,8 @@ return "Page"; case '\r': return "Return"; + case 27: + return "Escape"; case ' ': return "Space"; case 127: From ehuelsmann at common-lisp.net Wed May 6 20:39:52 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 06 May 2009 16:39:52 -0400 Subject: [armedbear-cvs] r11837 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 6 16:39:51 2009 New Revision: 11837 Log: Fix ticket #21 finally: JVM stack inconsistency error on inlining unwind-protect. The issue in the earlier attempts was that p1 outcomes can only be compiled once (first try) and that one cannot p1 the same form twice (one needs to create a copy; second try). Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed May 6 16:39:51 2009 @@ -299,8 +299,16 @@ (defun p1-unwind-protect (form) (if (= (length form) 2) (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...) + + ;; in order to compile the cleanup forms twice (see + ;; p2-unwind-protect-node), we need to p1 them twice; p1 outcomes + ;; can be compiled (in the same compiland?) only once. + ;; + ;; However, p1 transforms the forms being processed, so, we + ;; need to copy the forms to create a second copy. (let* ((block (make-block-node '(UNWIND-PROTECT))) ;; a bit of jumping through hoops... + (unwinding-forms (p1-body (copy-tree (cddr form)))) (unprotected-forms (p1-body (cddr form))) ;; ... because only the protected form is ;; protected by the UNWIND-PROTECT block @@ -308,6 +316,7 @@ (protected-form (p1 (cadr form)))) (setf (block-form block) `(unwind-protect ,protected-form + (progn , at unwinding-forms) , at unprotected-forms)) block))) 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 May 6 16:39:51 2009 @@ -7834,18 +7834,29 @@ (when (= (length form) 2) ; No cleanup form. (compile-form (second form) target nil) (return-from p2-unwind-protect-node)) + + ;; The internal representation of UNWIND-PROTECT + ;; as generated by P1-UNWIND-PROTECT differs a bit + ;; from what the spec says; ours is: + ;; (UNWIND-PROTECT protected-form (progn cleanup-forms) cleanup-forms), + ;; because we need to compile the cleanup forms twice and + ;; we can compile a p1 outcome only once. + ;; + ;; We used to use JSR and RET JVM instructions to prevent + ;; duplication of output code. However, this led to JVM stack + ;; inconsistency errors + ;; (see http://trac.common-lisp.net/armedbear/ticket/21) (let* ((protected-form (cadr form)) - (cleanup-forms (cddr form)) + (unwinding-form (caddr form)) + (cleanup-forms (cdddr form)) (*register* *register*) (exception-register (allocate-register)) (result-register (allocate-register)) (values-register (allocate-register)) - (return-address-register (allocate-register)) (BEGIN-PROTECTED-RANGE (gensym)) (END-PROTECTED-RANGE (gensym)) (HANDLER (gensym)) - (EXIT (gensym)) - (CLEANUP (gensym))) + (EXIT (gensym))) ;; Make sure there are no leftover multiple return values from previous calls. (emit-clear-values) @@ -7857,21 +7868,21 @@ (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) (astore values-register)) (label END-PROTECTED-RANGE)) - (emit 'jsr CLEANUP) + (let ((*register* *register*)) + (compile-form unwinding-form nil nil)) + (when (single-valued-p protected-form) + ;; otherwise, we'll load the values register below + (maybe-emit-clear-values unwinding-form)) (emit 'goto EXIT) ; Jump over handler. (label HANDLER) ; Start of exception handler. ;; The Throwable object is on the runtime stack. Stack depth is 1. (astore exception-register) - (emit 'jsr CLEANUP) ; Call cleanup forms. + (let ((*register* *register*)) + (dolist (subform cleanup-forms) + (compile-form subform nil nil))) (maybe-emit-clear-values cleanup-forms) (aload exception-register) (emit 'athrow) ; Re-throw exception. - (label CLEANUP) ; Cleanup forms. - ;; Return address is on stack here. - (astore return-address-register) - (dolist (subform cleanup-forms) - (compile-form subform nil nil)) - (emit 'ret return-address-register) (label EXIT) ;; Restore multiple values returned by protected form. (unless (single-valued-p protected-form) From ehuelsmann at common-lisp.net Thu May 7 18:01:09 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 07 May 2009 14:01:09 -0400 Subject: [armedbear-cvs] r11838 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 7 14:01:06 2009 New Revision: 11838 Log: Remove code handling JSR/RET instructions. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/opcodes.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 7 14:01:06 2009 @@ -1125,8 +1125,6 @@ 165 ; if_acmpeq 166 ; if_acmpne 167 ; goto - 168 ; jsr - 169 ; ret 176 ; areturn 177 ; return 190 ; arraylength @@ -1322,18 +1320,13 @@ i instruction-depth (+ depth instruction-stack))) (return-from walk-code)) (let ((opcode (instruction-opcode instruction))) - (unless (eql opcode 168) ; JSR - (setf depth (+ depth instruction-stack))) + (setf depth (+ depth instruction-stack)) (setf (instruction-depth instruction) depth) - (if (eql opcode 168) ; JSR - (let ((label (car (instruction-args instruction)))) - (declare (type symbol label)) - (walk-code code (symbol-value label) (1+ depth))) - (when (branch-opcode-p opcode) - (let ((label (car (instruction-args instruction)))) - (declare (type symbol label)) - (walk-code code (symbol-value label) depth)))) - (when (member opcode '(167 169 176 191)) ; GOTO RET ARETURN ATHROW + (when (branch-opcode-p opcode) + (let ((label (car (instruction-args instruction)))) + (declare (type symbol label)) + (walk-code code (symbol-value label) depth))) + (when (member opcode '(167 176 191)) ; GOTO ARETURN ATHROW ;; Current path ends. (return-from walk-code)))))) Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp Thu May 7 14:01:06 2009 @@ -220,8 +220,8 @@ (define-opcode if_acmpeq 165 3 -2) (define-opcode if_acmpne 166 3 -2) (define-opcode goto 167 3 0) -(define-opcode jsr 168 3 1) -(define-opcode ret 169 2 0) +;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated +;;(define-opcode ret 169 2 0) their use results in JVM verifier errors (define-opcode tableswitch 170 0 nil) (define-opcode lookupswitch 171 0 nil) (define-opcode ireturn 172 1 nil) From astalla at common-lisp.net Thu May 7 22:01:55 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 07 May 2009 18:01:55 -0400 Subject: [armedbear-cvs] r11839 - in trunk/abcl/src/org/armedbear/lisp/scripting: . lisp Message-ID: Author: astalla Date: Thu May 7 18:01:52 2009 New Revision: 11839 Log: Fixed compilation with temp files with JSR-223. Refactoring of AbclScriptEngine (mostly elimination of dead code). Changed policy of use of #'sys::%debugger-hook-function in an attempt to have the throwing debugger cover more cases; it still doesn't work always. Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Thu May 7 18:01:52 2009 @@ -38,84 +38,63 @@ public class AbclScriptEngine extends AbstractScriptEngine implements Invocable, Compilable { - private Interpreter interpreter; - private LispObject nonThrowingDebugHook; - private Function evalScript; - private Function compileScript; - private Function evalCompiledScript; - - public AbclScriptEngine() { - interpreter = Interpreter.getInstance(); - if(interpreter == null) { - interpreter = Interpreter.createInstance(); - } - this.nonThrowingDebugHook = Symbol.DEBUGGER_HOOK.getSymbolValue(); - try { - loadFromClasspath("/org/armedbear/lisp/scripting/lisp/packages.lisp"); - loadFromClasspath("/org/armedbear/lisp/scripting/lisp/abcl-script.lisp"); - loadFromClasspath("/org/armedbear/lisp/scripting/lisp/config.lisp"); - if(getClass().getResource("/abcl-script-config.lisp") != null) { - System.out.println("ABCL: loading configuration from " + getClass().getResource("/abcl-script-config.lisp")); - loadFromClasspath("/abcl-script-config.lisp"); - } - interpreter.eval("(abcl-script:configure-abcl)"); - System.out.println("ABCL: configured"); - evalScript = (Function) this.findSymbol("EVAL-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); - compileScript = (Function) this.findSymbol("COMPILE-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); - evalCompiledScript = (Function) this.findSymbol("EVAL-COMPILED-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); - } catch (ConditionThrowable e) { - throw new RuntimeException(e); - } - } - - public Interpreter getInterpreter() { - return interpreter; - } - - public void installNonThrowingDebugHook() { - installNonThrowingDebugHook(LispThread.currentThread()); - } - - public void installNonThrowingDebugHook(LispThread thread) { - thread.setSpecialVariable(Symbol.DEBUGGER_HOOK, this.nonThrowingDebugHook); - } - - public void installThrowingDebuggerHook(LispThread thread) throws ConditionThrowable { - Symbol dbgrhkfunSym; - dbgrhkfunSym = Lisp.PACKAGE_SYS.findAccessibleSymbol("%DEBUGGER-HOOK-FUNCTION"); - LispObject throwingDebugHook = dbgrhkfunSym.getSymbolFunction(); - thread.setSpecialVariable(Symbol.DEBUGGER_HOOK, throwingDebugHook); - } - - public void installThrowingDebuggerHook() throws ConditionThrowable { - installThrowingDebuggerHook(LispThread.currentThread()); - } - - public void setStandardInput(InputStream stream, LispThread thread) { - thread.setSpecialVariable(Symbol.STANDARD_INPUT, new Stream(stream, Symbol.CHARACTER, true)); - } - - public void setStandardInput(InputStream stream) { - setStandardInput(stream, LispThread.currentThread()); - } - - public void setInterpreter(Interpreter interpreter) { - this.interpreter = interpreter; - } - - public static String escape(String s) { - StringBuffer b = new StringBuffer(); - int len = s.length(); - char c; - for (int i = 0; i < len; ++i) { - c = s.charAt(i); - if (c == '\\' || c == '"') { - b.append('\\'); - } - b.append(c); - } - return b.toString(); + private Interpreter interpreter; + private Function evalScript; + private Function compileScript; + private Function evalCompiledScript; + + protected AbclScriptEngine() { + interpreter = Interpreter.getInstance(); + if(interpreter == null) { + interpreter = Interpreter.createInstance(); + } + try { + loadFromClasspath("/org/armedbear/lisp/scripting/lisp/packages.lisp"); + loadFromClasspath("/org/armedbear/lisp/scripting/lisp/abcl-script.lisp"); + loadFromClasspath("/org/armedbear/lisp/scripting/lisp/config.lisp"); + if(getClass().getResource("/abcl-script-config.lisp") != null) { + System.out.println("ABCL: loading configuration from " + getClass().getResource("/abcl-script-config.lisp")); + loadFromClasspath("/abcl-script-config.lisp"); + } + ((Function) interpreter.eval("#'abcl-script:configure-abcl")).execute(new JavaObject(this)); + System.out.println("ABCL: configured"); + evalScript = (Function) this.findSymbol("EVAL-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); + compileScript = (Function) this.findSymbol("COMPILE-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); + evalCompiledScript = (Function) this.findSymbol("EVAL-COMPILED-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); + } catch (ConditionThrowable e) { + throw new RuntimeException(e); + } + } + + public Interpreter getInterpreter() { + return interpreter; + } + + public void setStandardInput(InputStream stream, LispThread thread) { + thread.setSpecialVariable(Symbol.STANDARD_INPUT, new Stream(stream, Symbol.CHARACTER, true)); + } + + public void setStandardInput(InputStream stream) { + setStandardInput(stream, LispThread.currentThread()); + } + + public void setInterpreter(Interpreter interpreter) { + this.interpreter = interpreter; + } + + public static String escape(String s) { + StringBuffer b = new StringBuffer(); + int len = s.length(); + char c; + for (int i = 0; i < len; ++i) { + c = s.charAt(i); + if (c == '\\' || c == '"') { + b.append('\\'); + } + b.append(c); } + return b.toString(); + } public LispObject loadFromClasspath(String classpathResource) throws ConditionThrowable { InputStream istream = getClass().getResourceAsStream(classpathResource); @@ -244,26 +223,27 @@ return super.getContext(); } - private Object eval(Function evaluator, LispObject code, ScriptContext ctx) throws ScriptException { - ReaderInputStream in = null; - WriterOutputStream out = null; - LispObject retVal = null; - try { - in = new ReaderInputStream(ctx.getReader()); - out = new WriterOutputStream(ctx.getWriter()); - Stream outStream = new Stream(out, Symbol.CHARACTER); - Stream inStream = new Stream(in, Symbol.CHARACTER); - retVal = evaluator.execute(makeBindings(ctx.getBindings(ScriptContext.GLOBAL_SCOPE)), - makeBindings(ctx.getBindings(ScriptContext.ENGINE_SCOPE)), - inStream, outStream, - code, new JavaObject(ctx)); - return toJava(retVal); - } catch (ConditionThrowable e) { - throw new ScriptException(new Exception(e)); - } catch (IOException e) { - throw new ScriptException(e); - } + private Object eval(Function evaluator, LispObject code, ScriptContext ctx) throws ScriptException { + ReaderInputStream in = null; + WriterOutputStream out = null; + LispObject retVal = null; + try { + in = new ReaderInputStream(ctx.getReader()); + out = new WriterOutputStream(ctx.getWriter()); + Stream outStream = new Stream(out, Symbol.CHARACTER); + Stream inStream = new Stream(in, Symbol.CHARACTER); + + retVal = evaluator.execute(makeBindings(ctx.getBindings(ScriptContext.GLOBAL_SCOPE)), + makeBindings(ctx.getBindings(ScriptContext.ENGINE_SCOPE)), + inStream, outStream, + code, new JavaObject(ctx)); + return toJava(retVal); + } catch (ConditionThrowable e) { + throw new ScriptException(new Exception(e)); + } catch (IOException e) { + throw new ScriptException(e); } + } @Override public Object eval(String code, ScriptContext ctx) throws ScriptException { Modified: trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp Thu May 7 18:01:52 2009 @@ -57,19 +57,20 @@ :collect `(jcall +put-binding+ ,java-bindings ,(car jbinding) ,(car binding)))) -(defmacro with-script-context ((global-bindings engine-bindings stdin stdout script-context) - body) +(defmacro eval-in-script-context ((global-bindings engine-bindings stdin stdout script-context) + body) + "Sets up an environment in which to evaluate a piece of code coming from Java through the JSR-223 methods." (let ((actual-global-bindings (gensym)) (actual-engine-bindings (gensym))) `(let ((*package* (find-package :abcl-script-user)) (*standard-input* ,stdin) (*standard-output* ,stdout) + (*debugger-hook* (if *use-throwing-debugger* + #'sys::%debugger-hook-function + *debugger-hook*)) (,actual-global-bindings (generate-bindings ,global-bindings)) (,actual-engine-bindings (generate-bindings ,engine-bindings))) - (eval `(let ((*standard-input* ,,stdin) - (*standard-output* ,,stdout) - (*package* (find-package :abcl-script-user))) - (let (,@,actual-global-bindings) + (eval `(let (,@,actual-global-bindings) (let (,@,actual-engine-bindings) (prog1 (progn ,@,body) @@ -81,17 +82,17 @@ ,@(generate-java-bindings ,engine-bindings ,actual-engine-bindings - (jcall +get-bindings+ ,script-context +engine-scope+)))))))))) + (jcall +get-bindings+ ,script-context +engine-scope+))))))))) (defun eval-script (global-bindings engine-bindings stdin stdout code-string script-context) - (with-script-context (global-bindings engine-bindings stdin stdout script-context) + (eval-in-script-context (global-bindings engine-bindings stdin stdout script-context) (read-from-string (concatenate 'string "(" code-string ")")))) (defun eval-compiled-script (global-bindings engine-bindings stdin stdout function script-context) - (with-script-context (global-bindings engine-bindings stdin stdout script-context) + (eval-in-script-context (global-bindings engine-bindings stdin stdout script-context) `((funcall ,function)))) (defun compile-script (code-string) @@ -102,39 +103,39 @@ (jcall (jmethod "java.io.File" "deleteOnExit") tmp-file) ;to be really-really-really sure... (unwind-protect (progn - (with-open-file (stream tmp-file-path :direction :output :if-exists :overwrite) - (prin1 code-string stream) + (with-open-file (stream tmp-file-path :direction :output) + (princ "(in-package :abcl-script-user)" stream) + (princ code-string stream) (finish-output stream)) (let ((compiled-file (compile-file tmp-file-path))) (jcall (jmethod "java.io.File" "deleteOnExit") (jnew (jconstructor "java.io.File" "java.lang.String") (namestring compiled-file))) - (lambda () (load compiled-file)))) + (lambda () + (let ((*package* (find-package :abcl-script-user))) + (load compiled-file :verbose t :print t))))) (delete-file tmp-file-path))) (eval `(compile nil (lambda () ,@(let ((*package* (find-package :abcl-script-user))) - (read-from-string (concatenate 'string "(" code-string ")")))))))) + (read-from-string + (concatenate 'string "(" code-string " cl:t)")))))))) ;return T in conformity of what LOAD does. -;;Java interface implementation +;;Java interface implementation - TODO (defvar *interface-implementation-map* (make-hash-table :test #'equal)) (defun find-java-interface-implementation (interface) (gethash interface *interface-implementation-map*)) -(defun register-java-interface-implementation (interface impl) - (setf (gethash interface *interface-implementation-map*) impl)) +(defun register-java-interface-implementation (interface implementation &optional lisp-this) + (setf (gethash interface *interface-implementation-map*) + (jmake-proxy interface implementation lisp-this))) (defun remove-java-interface-implementation (interface) (remhash interface *interface-implementation-map*)) -(defun define-java-interface-implementation (interface implementation &optional lisp-this) - (register-java-interface-implementation - interface - (jmake-proxy interface implementation lisp-this))) - ;Let's load it so asdf package is already defined when loading config.lisp (require 'asdf) \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp Thu May 7 18:01:52 2009 @@ -41,16 +41,12 @@ (defparameter *compile-using-temp-files* t) -(defconstant +standard-debugger-hook+ *debugger-hook*) - -(defun configure-abcl () - (setq *debugger-hook* - (if *use-throwing-debugger* - #'sys::%debugger-hook-function - +standard-debugger-hook+)) +(defun configure-abcl (abcl-script-engine) (when *launch-swank-at-startup* (unless *swank-dir* (error "Swank directory not specified, please set *swank-dir*")) + (when *use-throwing-debugger* + (setf *debugger-hook* #'sys::%debugger-hook-function)) (pushnew *swank-dir* asdf:*central-registry* :test #'equal) (asdf:oos 'asdf:load-op :swank) (ext:make-thread (lambda () (funcall (find-symbol From vvoutilainen at common-lisp.net Fri May 8 17:30:50 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Fri, 08 May 2009 13:30:50 -0400 Subject: [armedbear-cvs] r11840 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Fri May 8 13:30:48 2009 New Revision: 11840 Log: Clean up p2-list*. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 8 13:30:48 2009 @@ -6547,57 +6547,27 @@ (emit-clear-values)) (emit-move-from-stack target))))) +(defun cons-for-list* (args target representation) + (let ((cons-heads (butlast args 1))) + (dolist (cons-head cons-heads) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form cons-head 'stack nil)) + (compile-form (first (last args)) 'stack nil) + (dolist (cons-head cons-heads) + (declare (ignore cons-head)) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))) + (apply #'maybe-emit-clear-values args) + (emit-move-from-stack target representation))) + (defun p2-list* (form target representation) (let* ((args (cdr form)) (length (length args))) - (cond ((= length 1) - (compile-forms-and-maybe-emit-clear-values (first args) 'stack nil) - (emit-move-from-stack target representation)) - ((= length 2) - (let ((arg1 (first args)) - (arg2 (second args))) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) - (maybe-emit-clear-values arg1 arg2) - (emit-move-from-stack target representation))) - ((= length 3) - (let ((arg1 (first args)) - (arg2 (second args)) - (arg3 (third args))) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form arg1 'stack nil) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form arg2 'stack nil) - (compile-form arg3 'stack nil) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) - (maybe-emit-clear-values arg1 arg2 arg3) - (emit-move-from-stack target representation))) - ((= length 4) - (let ((arg1 (first args)) - (arg2 (second args)) - (arg3 (third args)) - (arg4 (fourth args))) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form arg1 'stack nil) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form arg2 'stack nil) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form arg3 'stack nil) - (compile-form arg4 'stack nil) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) - (maybe-emit-clear-values arg1 arg2 arg3 arg4) - (emit-move-from-stack target representation))) + (cond ((= length 1) + (compile-forms-and-maybe-emit-clear-values (first args) 'stack nil) + (emit-move-from-stack target representation)) + ((>= 4 length 2) + (cons-for-list* args target representation)) (t (compile-function-call form target representation))))) From ehuelsmann at common-lisp.net Fri May 8 18:58:04 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 May 2009 14:58:04 -0400 Subject: [armedbear-cvs] r11841 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 8 14:58:03 2009 New Revision: 11841 Log: Simplify PROCESS-DEFCONSTANT; the only thing the code we're removing was doing is prevent a #. reader macro on the dumped third list element. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri May 8 14:58:03 2009 @@ -83,12 +83,7 @@ ;; whether or not references to name appear in the file) and that ;; it always evaluates to the same value." (eval form) - (cond ((structure-object-p (third form)) - (multiple-value-bind (creation-form initialization-form) - (make-load-form (third form)) - (dump-form (list 'DEFCONSTANT (second form) creation-form) stream))) - (t - (dump-form form stream))) + (dump-form form stream) (%stream-terpri stream)) (declaim (ftype (function (t) t) note-toplevel-form)) From ehuelsmann at common-lisp.net Fri May 8 19:31:13 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 May 2009 15:31:13 -0400 Subject: [armedbear-cvs] r11842 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 8 15:31:12 2009 New Revision: 11842 Log: Re-order p2-block-node, to make more clear what the COND was actually doing. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 8 15:31:12 2009 @@ -4620,57 +4620,56 @@ (aver (block-node-p block))) (let* ((*blocks* (cons block *blocks*)) (*register* *register*)) - (cond ((block-return-p block) - (setf (block-target block) target) - (dformat t "p2-block-node lastSpecialBinding~%") - (dformat t "*all-variables* = ~S~%" - (mapcar #'variable-name *all-variables*)) - (when (block-needs-environment-restoration block) - ;; Save the current dynamic environment. - (setf (block-environment-register block) (allocate-register)) - (save-dynamic-environment (block-environment-register block))) - (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)) - (when (block-environment-register block) - ;; We saved the dynamic environment above. Restore it now. - (restore-dynamic-environment (block-environment-register block))) - (fix-boxing representation nil) - ) - (t - ;; No explicit returns. - (compile-progn-body (cddr (block-form block)) target representation))))) + (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*)) + (when (block-needs-environment-restoration block) + ;; Save the current dynamic environment. + (setf (block-environment-register block) (allocate-register)) + (save-dynamic-environment (block-environment-register block))) + (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)) + (when (block-environment-register block) + ;; We saved the dynamic environment above. Restore it now. + (restore-dynamic-environment (block-environment-register block))) + (fix-boxing representation nil))))) (defknown p2-return-from (t t t) t) (defun p2-return-from (form target representation) From ehuelsmann at common-lisp.net Fri May 8 21:09:10 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 May 2009 17:09:10 -0400 Subject: [armedbear-cvs] r11843 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 8 17:09:09 2009 New Revision: 11843 Log: Reflow PROCESS-TOPLEVEL-FORM in order to make more lines meet our 80-character length limit. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri May 8 17:09:09 2009 @@ -99,217 +99,220 @@ (declaim (ftype (function (t stream t) t) process-toplevel-form)) (defun process-toplevel-form (form stream compile-time-too) - (cond ((atom form) - (when compile-time-too - (eval form))) - (t - (let ((operator (%car form))) - (case operator - (MACROLET - (process-toplevel-macrolet form stream compile-time-too) - (return-from process-toplevel-form)) - ((IN-PACKAGE DEFPACKAGE) - (note-toplevel-form form) - (setf form (precompile-form form nil)) - (eval form) - ;; Force package prefix to be used when dumping form. - (let ((*package* +keyword-package+)) - (dump-form form stream)) - (%stream-terpri stream) - (return-from process-toplevel-form)) - ((DEFVAR DEFPARAMETER) - (note-toplevel-form form) - (if compile-time-too - (eval form) - ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form, - ;; the compiler must recognize that the name has been proclaimed - ;; special. However, it must neither evaluate the initial-value - ;; form nor assign the dynamic variable named NAME at compile - ;; time." - (let ((name (second form))) - (%defvar name)))) - (DEFCONSTANT - (note-toplevel-form form) - (process-defconstant form stream) - (return-from process-toplevel-form)) - (DEFUN - (note-toplevel-form form) - (let* ((name (second form)) - (block-name (fdefinition-block-name name)) - (lambda-list (third form)) - (body (nthcdr 3 form)) - (*speed* *speed*) - (*space* *space*) - (*safety* *safety*) - (*debug* *debug*)) - (multiple-value-bind (body decls doc) - (parse-body body) - (let* ((expr `(lambda ,lambda-list , at decls (block ,block-name , at body))) - (classfile-name (next-classfile-name)) - (classfile (report-error - (jvm:compile-defun name expr nil classfile-name))) - (compiled-function (verify-load classfile))) - (cond (compiled-function - (setf form - `(fset ',name - (load-compiled-function ,(file-namestring classfile)) - ,*source-position* - ',lambda-list - ,doc)) - (when compile-time-too - (fset name compiled-function))) - (t - ;; FIXME This should be a warning or error of some sort... - (format *error-output* "; Unable to compile function ~A~%" name) - (let ((precompiled-function (precompile-form expr nil))) - (setf form - `(fset ',name - ,precompiled-function - ,*source-position* - ',lambda-list - ,doc))) - (when compile-time-too - (eval form))))) - (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) - ;; FIXME Need to support SETF functions too! - (setf (inline-expansion name) - (jvm::generate-inline-expansion block-name lambda-list body)) - (dump-form `(setf (inline-expansion ',name) ',(inline-expansion name)) - stream) - (%stream-terpri stream))) - (push name jvm::*functions-defined-in-current-file*) - (note-name-defined name) - ;; If NAME is not fbound, provide a dummy definition so that - ;; getSymbolFunctionOrDie() will succeed when we try to verify that - ;; functions defined later in the same file can be loaded correctly. - (unless (fboundp name) - (setf (fdefinition name) #'dummy) - (push name *fbound-names*)))) - ((DEFGENERIC DEFMETHOD) - (note-toplevel-form form) - (note-name-defined (second form)) - (let ((*compile-print* nil)) - (process-toplevel-form (macroexpand-1 form *compile-file-environment*) - stream compile-time-too)) - (return-from process-toplevel-form)) - (DEFMACRO - (note-toplevel-form form) - (let ((name (second form))) - (eval form) - (let* ((expr (function-lambda-expression (macro-function name))) - (classfile-name (next-classfile-name)) - (classfile - (ignore-errors - (jvm:compile-defun nil expr nil classfile-name)))) - (if (verify-load classfile) - (progn - (setf form - (if (special-operator-p name) - `(put ',name 'macroexpand-macro - (make-macro ',name - (load-compiled-function - ,(file-namestring classfile)))) - `(fset ',name - (make-macro ',name - (load-compiled-function - ,(file-namestring classfile))) - ,*source-position* - ',(third form))))) - ;; FIXME error or warning - (format *error-output* "; Unable to compile macro ~A~%" name))))) - (DEFTYPE - (note-toplevel-form form) - (eval form)) - (EVAL-WHEN - (multiple-value-bind (ct lt e) - (parse-eval-when-situations (cadr form)) - (let ((new-compile-time-too (or ct - (and compile-time-too e))) - (body (cddr form))) - (cond (lt - (process-toplevel-progn body stream new-compile-time-too)) - (new-compile-time-too - (eval `(progn , at body))))) - (return-from process-toplevel-form))) - (LOCALLY - ;; FIXME Need to handle special declarations too! - (let ((*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*space* *space*) - (*inline-declarations* *inline-declarations*)) - (multiple-value-bind (forms decls) - (parse-body (cdr form) nil) - (process-optimization-declarations decls) - (process-toplevel-progn forms stream compile-time-too) - (return-from process-toplevel-form)))) - (PROGN - (process-toplevel-progn (cdr form) stream compile-time-too) - (return-from process-toplevel-form)) - (DECLARE - (compiler-style-warn "Misplaced declaration: ~S" form)) - (t - (when (and (symbolp operator) - (macro-function operator *compile-file-environment*)) - (note-toplevel-form form) - ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in - ;; case the form being expanded expands into something that needs - ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). - (let ((*compile-print* nil)) - (process-toplevel-form (macroexpand-1 form *compile-file-environment*) - stream compile-time-too)) - (return-from process-toplevel-form)) - - (cond ((eq operator 'QUOTE) -;; (setf form (precompile-form form nil)) - (when compile-time-too - (eval form)) - (return-from process-toplevel-form) - ) - ((eq operator 'PUT) - (setf form (precompile-form form nil))) - ((eq operator 'COMPILER-DEFSTRUCT) - (setf form (precompile-form form nil))) - ((eq operator 'PROCLAIM) - (setf form (precompile-form form nil))) - ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) - (or (keywordp (second form)) - (and (listp (second form)) - (eq (first (second form)) 'QUOTE)))) - (setf form (precompile-form form nil))) - ((eq operator 'IMPORT) - (setf form (precompile-form form nil)) - ;; Make sure package prefix is printed when symbols are imported. - (let ((*package* +keyword-package+)) - (dump-form form stream)) - (%stream-terpri stream) - (when compile-time-too - (eval form)) - (return-from process-toplevel-form)) - ((and (eq operator '%SET-FDEFINITION) - (eq (car (second form)) 'QUOTE) - (consp (third form)) - (eq (%car (third form)) 'FUNCTION) - (symbolp (cadr (third form)))) - (setf form (precompile-form form nil))) -;; ((memq operator '(LET LET*)) -;; (let ((body (cddr form))) -;; (if (dolist (subform body nil) -;; (when (and (consp subform) (eq (%car subform) 'DEFUN)) -;; (return t))) -;; (setf form (convert-toplevel-form form)) -;; (setf form (precompile-form form nil))))) - ((eq operator 'mop::ensure-method) - (setf form (convert-ensure-method form))) - ((and (symbolp operator) - (not (special-operator-p operator)) - (null (cdr form))) - (setf form (precompile-form form nil))) - (t -;; (setf form (precompile-form form nil)) - (note-toplevel-form form) - (setf form (convert-toplevel-form form)) - ))))))) + (if (atom form) + (when compile-time-too + (eval form)) + (progn + (let ((operator (%car form))) + (case operator + (MACROLET + (process-toplevel-macrolet form stream compile-time-too) + (return-from process-toplevel-form)) + ((IN-PACKAGE DEFPACKAGE) + (note-toplevel-form form) + (setf form (precompile-form form nil)) + (eval form) + ;; Force package prefix to be used when dumping form. + (let ((*package* +keyword-package+)) + (dump-form form stream)) + (%stream-terpri stream) + (return-from process-toplevel-form)) + ((DEFVAR DEFPARAMETER) + (note-toplevel-form form) + (if compile-time-too + (eval form) + ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form, + ;; the compiler must recognize that the name has been proclaimed + ;; special. However, it must neither evaluate the initial-value + ;; form nor assign the dynamic variable named NAME at compile + ;; time." + (let ((name (second form))) + (%defvar name)))) + (DEFCONSTANT + (note-toplevel-form form) + (process-defconstant form stream) + (return-from process-toplevel-form)) + (DEFUN + (note-toplevel-form form) + (let* ((name (second form)) + (block-name (fdefinition-block-name name)) + (lambda-list (third form)) + (body (nthcdr 3 form)) + (*speed* *speed*) + (*space* *space*) + (*safety* *safety*) + (*debug* *debug*)) + (multiple-value-bind (body decls doc) + (parse-body body) + (let* ((expr `(lambda ,lambda-list + , at decls (block ,block-name , at body))) + (classfile-name (next-classfile-name)) + (classfile (report-error + (jvm:compile-defun name expr nil + classfile-name))) + (compiled-function (verify-load classfile))) + (cond + (compiled-function + (setf form + `(fset ',name + (load-compiled-function ,(file-namestring classfile)) + ,*source-position* + ',lambda-list + ,doc)) + (when compile-time-too + (fset name compiled-function))) + (t + ;; FIXME Should be a warning or error of some sort... + (format *error-output* + "; Unable to compile function ~A~%" name) + (let ((precompiled-function (precompile-form expr nil))) + (setf form + `(fset ',name + ,precompiled-function + ,*source-position* + ',lambda-list + ,doc))) + (when compile-time-too + (eval form))))) + (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) + ;; FIXME Need to support SETF functions too! + (setf (inline-expansion name) + (jvm::generate-inline-expansion block-name + lambda-list body)) + (dump-form `(setf (inline-expansion ',name) + ',(inline-expansion name)) + stream) + (%stream-terpri stream))) + (push name jvm::*functions-defined-in-current-file*) + (note-name-defined name) + ;; If NAME is not fbound, provide a dummy definition so that + ;; getSymbolFunctionOrDie() will succeed when we try to verify that + ;; functions defined later in the same file can be loaded correctly. + (unless (fboundp name) + (setf (fdefinition name) #'dummy) + (push name *fbound-names*)))) + ((DEFGENERIC DEFMETHOD) + (note-toplevel-form form) + (note-name-defined (second form)) + (let ((*compile-print* nil)) + (process-toplevel-form (macroexpand-1 form *compile-file-environment*) + stream compile-time-too)) + (return-from process-toplevel-form)) + (DEFMACRO + (note-toplevel-form form) + (let ((name (second form))) + (eval form) + (let* ((expr (function-lambda-expression (macro-function name))) + (classfile-name (next-classfile-name)) + (classfile + (ignore-errors + (jvm:compile-defun nil expr nil classfile-name)))) + (if (null (verify-load classfile)) + ;; FIXME error or warning + (format *error-output* "; Unable to compile macro ~A~%" name) + (progn + (setf form + (if (special-operator-p name) + `(put ',name 'macroexpand-macro + (make-macro ',name + (load-compiled-function + ,(file-namestring classfile)))) + `(fset ',name + (make-macro ',name + (load-compiled-function + ,(file-namestring classfile))) + ,*source-position* + ',(third form))))))))) + (DEFTYPE + (note-toplevel-form form) + (eval form)) + (EVAL-WHEN + (multiple-value-bind (ct lt e) + (parse-eval-when-situations (cadr form)) + (let ((new-compile-time-too (or ct (and compile-time-too e))) + (body (cddr form))) + (if lt + (process-toplevel-progn body stream new-compile-time-too) + (when new-compile-time-too + (eval `(progn , at body))))) + (return-from process-toplevel-form))) + (LOCALLY + ;; FIXME Need to handle special declarations too! + (let ((*speed* *speed*) + (*safety* *safety*) + (*debug* *debug*) + (*space* *space*) + (*inline-declarations* *inline-declarations*)) + (multiple-value-bind (forms decls) + (parse-body (cdr form) nil) + (process-optimization-declarations decls) + (process-toplevel-progn forms stream compile-time-too) + (return-from process-toplevel-form)))) + (PROGN + (process-toplevel-progn (cdr form) stream compile-time-too) + (return-from process-toplevel-form)) + (DECLARE + (compiler-style-warn "Misplaced declaration: ~S" form)) + (t + (when (and (symbolp operator) + (macro-function operator *compile-file-environment*)) + (note-toplevel-form form) + ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in + ;; case the form being expanded expands into something that needs + ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). + (let ((*compile-print* nil)) + (process-toplevel-form (macroexpand-1 form *compile-file-environment*) + stream compile-time-too)) + (return-from process-toplevel-form)) + + (cond ((eq operator 'QUOTE) +;;; (setf form (precompile-form form nil)) + (when compile-time-too + (eval form)) + (return-from process-toplevel-form)) + ((eq operator 'PUT) + (setf form (precompile-form form nil))) + ((eq operator 'COMPILER-DEFSTRUCT) + (setf form (precompile-form form nil))) + ((eq operator 'PROCLAIM) + (setf form (precompile-form form nil))) + ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) + (or (keywordp (second form)) + (and (listp (second form)) + (eq (first (second form)) 'QUOTE)))) + (setf form (precompile-form form nil))) + ((eq operator 'IMPORT) + (setf form (precompile-form form nil)) + ;; Make sure package prefix is printed when symbols are imported. + (let ((*package* +keyword-package+)) + (dump-form form stream)) + (%stream-terpri stream) + (when compile-time-too + (eval form)) + (return-from process-toplevel-form)) + ((and (eq operator '%SET-FDEFINITION) + (eq (car (second form)) 'QUOTE) + (consp (third form)) + (eq (%car (third form)) 'FUNCTION) + (symbolp (cadr (third form)))) + (setf form (precompile-form form nil))) +;;; ((memq operator '(LET LET*)) +;;; (let ((body (cddr form))) +;;; (if (dolist (subform body nil) +;;; (when (and (consp subform) (eq (%car subform) 'DEFUN)) +;;; (return t))) +;;; (setf form (convert-toplevel-form form)) +;;; (setf form (precompile-form form nil))))) + ((eq operator 'mop::ensure-method) + (setf form (convert-ensure-method form))) + ((and (symbolp operator) + (not (special-operator-p operator)) + (null (cdr form))) + (setf form (precompile-form form nil))) + (t +;;; (setf form (precompile-form form nil)) + (note-toplevel-form form) + (setf form (convert-toplevel-form form))))))))) (when (consp form) (dump-form form stream) (%stream-terpri stream)) From vvoutilainen at common-lisp.net Fri May 8 21:11:15 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Fri, 08 May 2009 17:11:15 -0400 Subject: [armedbear-cvs] r11844 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Fri May 8 17:11:15 2009 New Revision: 11844 Log: More list/list* cleanup, also don't use default nil values for my recently added &optionals, that's not necessary. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 8 17:11:15 2009 @@ -1001,7 +1001,7 @@ ;; the value of a constant defined with DEFCONSTANT, calling built-in Lisp ;; functions with a wrong number of arguments or malformed keyword argument ;; lists, and using unrecognized declaration specifiers." (3.2.5) -(defun check-number-of-args (form n &optional (minimum nil)) +(defun check-number-of-args (form n &optional minimum) (declare (type fixnum n)) (let* ((op (car form)) (args (cdr form)) @@ -6505,68 +6505,45 @@ (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+))) (emit-move-from-stack target representation))) +(defun cons-for-list/list* (args target representation &optional list-star-p) + (let ((cons-heads (if list-star-p + (butlast args 1) + args))) + (dolist (cons-head cons-heads) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form cons-head 'stack nil)) + (when list-star-p + (compile-form (first (last args)) 'stack nil)) + (unless list-star-p + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 1)) + (setf cons-heads (nbutlast cons-heads 1))) + (dolist (cons-head cons-heads) + (declare (ignore cons-head)) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))) + (when list-star-p + (apply #'maybe-emit-clear-values args) + (emit-move-from-stack target representation)))) + (defun p2-list (form target representation) (let* ((args (cdr form)) (len (length args))) - (cond ((> len 9) ; list1() through list9() are defined in Lisp.java. + (cond ((> len 4) ; list1() through list9() are defined in Lisp.java. (compile-function-call form target representation)) (t (cond ((zerop len) (emit-push-nil)) - ((= len 1) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form (first args) 'stack nil) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 1))) - ((and (>= *speed* *space*) - (< len 4)) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form (first args) 'stack nil) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form (second args) 'stack nil) - (when (= len 3) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form (third args) 'stack nil)) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 1)) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) - (when (= len 3) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)))) - (t - (dolist (arg args) - (compile-form arg 'stack nil)) - (let ((s (copy-seq "list "))) - (setf (schar s 4) (code-char (+ (char-code #\0) len))) - (emit-invokestatic +lisp-class+ s - (make-list len :initial-element +lisp-object+) - +lisp-cons+)))) + ((>= 4 len 1) + (cons-for-list/list* args target representation))) (unless (every 'single-valued-p args) (emit-clear-values)) (emit-move-from-stack target))))) -(defun cons-for-list* (args target representation) - (let ((cons-heads (butlast args 1))) - (dolist (cons-head cons-heads) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form cons-head 'stack nil)) - (compile-form (first (last args)) 'stack nil) - (dolist (cons-head cons-heads) - (declare (ignore cons-head)) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))) - (apply #'maybe-emit-clear-values args) - (emit-move-from-stack target representation))) - (defun p2-list* (form target representation) (let* ((args (cdr form)) (length (length args))) - (cond ((= length 1) - (compile-forms-and-maybe-emit-clear-values (first args) 'stack nil) - (emit-move-from-stack target representation)) - ((>= 4 length 2) - (cons-for-list* args target representation)) + (cond ((>= 4 length 1) + (cons-for-list/list* args target representation t)) (t (compile-function-call form target representation))))) From ehuelsmann at common-lisp.net Fri May 8 21:52:37 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 May 2009 17:52:37 -0400 Subject: [armedbear-cvs] r11845 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 8 17:52:36 2009 New Revision: 11845 Log: Use WITH-SAVED-COMPILER-POLICY in COMPILE-FILE. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri May 8 17:52:36 2009 @@ -137,52 +137,49 @@ (let* ((name (second form)) (block-name (fdefinition-block-name name)) (lambda-list (third form)) - (body (nthcdr 3 form)) - (*speed* *speed*) - (*space* *space*) - (*safety* *safety*) - (*debug* *debug*)) - (multiple-value-bind (body decls doc) - (parse-body body) - (let* ((expr `(lambda ,lambda-list - , at decls (block ,block-name , at body))) - (classfile-name (next-classfile-name)) - (classfile (report-error - (jvm:compile-defun name expr nil - classfile-name))) - (compiled-function (verify-load classfile))) - (cond - (compiled-function - (setf form - `(fset ',name - (load-compiled-function ,(file-namestring classfile)) - ,*source-position* - ',lambda-list - ,doc)) - (when compile-time-too - (fset name compiled-function))) - (t - ;; FIXME Should be a warning or error of some sort... - (format *error-output* - "; Unable to compile function ~A~%" name) - (let ((precompiled-function (precompile-form expr nil))) + (body (nthcdr 3 form))) + (jvm::with-saved-compiler-policy + (multiple-value-bind (body decls doc) + (parse-body body) + (let* ((expr `(lambda ,lambda-list + , at decls (block ,block-name , at body))) + (classfile-name (next-classfile-name)) + (classfile (report-error + (jvm:compile-defun name expr nil + classfile-name))) + (compiled-function (verify-load classfile))) + (cond + (compiled-function (setf form `(fset ',name - ,precompiled-function + (load-compiled-function ,(file-namestring classfile)) ,*source-position* ',lambda-list - ,doc))) - (when compile-time-too - (eval form))))) - (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) + ,doc)) + (when compile-time-too + (fset name compiled-function))) + (t + ;; FIXME Should be a warning or error of some sort... + (format *error-output* + "; Unable to compile function ~A~%" name) + (let ((precompiled-function (precompile-form expr nil))) + (setf form + `(fset ',name + ,precompiled-function + ,*source-position* + ',lambda-list + ,doc))) + (when compile-time-too + (eval form))))) + (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) ;; FIXME Need to support SETF functions too! - (setf (inline-expansion name) - (jvm::generate-inline-expansion block-name - lambda-list body)) - (dump-form `(setf (inline-expansion ',name) - ',(inline-expansion name)) - stream) - (%stream-terpri stream))) + (setf (inline-expansion name) + (jvm::generate-inline-expansion block-name + lambda-list body)) + (dump-form `(setf (inline-expansion ',name) + ',(inline-expansion name)) + stream) + (%stream-terpri stream)))) (push name jvm::*functions-defined-in-current-file*) (note-name-defined name) ;; If NAME is not fbound, provide a dummy definition so that @@ -238,11 +235,7 @@ (return-from process-toplevel-form))) (LOCALLY ;; FIXME Need to handle special declarations too! - (let ((*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*space* *space*) - (*inline-declarations* *inline-declarations*)) + (jvm::with-saved-compiler-policy (multiple-value-bind (forms decls) (parse-body (cdr form) nil) (process-optimization-declarations decls) @@ -255,7 +248,7 @@ (compiler-style-warn "Misplaced declaration: ~S" form)) (t (when (and (symbolp operator) - (macro-function operator *compile-file-environment*)) + (macro-function operator *compile-file-environment*)) (note-toplevel-form form) ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in ;; case the form being expanded expands into something that needs @@ -337,10 +330,7 @@ (when (and function-form (consp function-form) (eq (%car function-form) 'FUNCTION)) (let ((lambda-expression (cadr function-form))) - (let* ((*speed* *speed*) - (*space* *space*) - (*safety* *safety*) - (*debug* *debug*)) + (jvm::with-saved-compiler-policy (let* ((classfile-name (next-classfile-name)) (classfile (report-error (jvm:compile-defun nil lambda-expression nil classfile-name))) @@ -429,52 +419,51 @@ (when *compile-verbose* (format t "; Compiling ~A ...~%" namestring)) (with-compilation-unit () - (with-open-file (out temp-file :direction :output :if-exists :supersede) + (with-open-file (out temp-file + :direction :output :if-exists :supersede) (let ((*readtable* *readtable*) (*read-default-float-format* *read-default-float-format*) (*read-base* *read-base*) (*package* *package*) - (*speed* *speed*) - (*space* *space*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*) (jvm::*functions-defined-in-current-file* '()) (*fbound-names* '()) (*fasl-anonymous-package* (%make-package))) - (jvm::with-file-compilation - (write "; -*- Mode: Lisp -*-" :escape nil :stream out) - (%stream-terpri out) - (let ((*package* (find-package '#:cl))) - (write (list 'init-fasl :version *fasl-version*) :stream out) + (jvm::with-saved-compiler-policy + (jvm::with-file-compilation + (write "; -*- Mode: Lisp -*-" :escape nil :stream out) (%stream-terpri out) - (write (list 'setq '*source* *compile-file-truename*) :stream out) - (%stream-terpri out)) - (handler-bind ((style-warning #'(lambda (c) - (declare (ignore c)) - (setf warnings-p t) - nil)) - ((or warning - compiler-error) #'(lambda (c) - (declare (ignore c)) - (setf warnings-p t - failure-p t) - nil))) - (loop - (let* ((*source-position* (file-position in)) - (jvm::*source-line-number* (stream-line-number in)) - (form (read in nil in)) - (*compiler-error-context* form)) - (when (eq form in) - (return)) - (process-toplevel-form form out nil)))) - (dolist (name *fbound-names*) - (fmakunbound name)))))) + (let ((*package* (find-package '#:cl))) + (write (list 'init-fasl :version *fasl-version*) + :stream out) + (%stream-terpri out) + (write (list 'setq '*source* *compile-file-truename*) + :stream out) + (%stream-terpri out)) + (handler-bind ((style-warning #'(lambda (c) + (declare (ignore c)) + (setf warnings-p t) + nil)) + ((or warning + compiler-error) #'(lambda (c) + (declare (ignore c)) + (setf warnings-p t + failure-p t) + nil))) + (loop + (let* ((*source-position* (file-position in)) + (jvm::*source-line-number* (stream-line-number in)) + (form (read in nil in)) + (*compiler-error-context* form)) + (when (eq form in) + (return)) + (process-toplevel-form form out nil)))) + (dolist (name *fbound-names*) + (fmakunbound name))))))) (rename-file temp-file output-file) (when *compile-file-zip* (let* ((type ;; Don't use ".zip", it'll result in an extension - ;; with a dot, which is rejected by NAMESTRING + ;; with a dot, which is rejected by NAMESTRING (%format nil "~A~A" (pathname-type output-file) "-zip")) (zipfile (namestring (merge-pathnames (make-pathname :type type) @@ -498,7 +487,8 @@ (setf elapsed (/ (- (get-internal-real-time) start) 1000.0)) (when *compile-verbose* - (format t "~&; Wrote ~A (~A seconds)~%" (namestring output-file) elapsed)))) + (format t "~&; Wrote ~A (~A seconds)~%" + (namestring output-file) elapsed)))) (values (truename output-file) warnings-p failure-p))) (defun compile-file-if-needed (input-file &rest allargs &key force-compile From vvoutilainen at common-lisp.net Fri May 8 21:54:05 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Fri, 08 May 2009 17:54:05 -0400 Subject: [armedbear-cvs] r11846 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Fri May 8 17:54:04 2009 New Revision: 11846 Log: Yet another cleanup for p2-list/list*. 1) use pop instead of nbutlast 2) use if instead of when/unless 3) do clear-values in cons-for-list/list* 4) well, do _everything_ in cons-for-list/list* :) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 8 17:54:04 2009 @@ -6505,47 +6505,45 @@ (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+))) (emit-move-from-stack target representation))) -(defun cons-for-list/list* (args target representation &optional list-star-p) - (let ((cons-heads (if list-star-p - (butlast args 1) - args))) - (dolist (cons-head cons-heads) - (emit 'new +lisp-cons-class+) - (emit 'dup) - (compile-form cons-head 'stack nil)) - (when list-star-p - (compile-form (first (last args)) 'stack nil)) - (unless list-star-p - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 1)) - (setf cons-heads (nbutlast cons-heads 1))) - (dolist (cons-head cons-heads) - (declare (ignore cons-head)) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))) - (when list-star-p - (apply #'maybe-emit-clear-values args) - (emit-move-from-stack target representation)))) +(defun cons-for-list/list* (form target representation &optional list-star-p) + (let* ((args (cdr form)) + (length (length args)) + (cons-heads (if list-star-p + (butlast args 1) + args))) + (cond ((>= 4 length 1) + (dolist (cons-head cons-heads) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form cons-head 'stack nil)) + (if list-star-p + (compile-form (first (last args)) 'stack nil) + (progn + (emit-invokespecial-init + +lisp-cons-class+ (lisp-object-arg-types 1)) + (pop cons-heads))) ; we've handled one of the args, so remove it + (dolist (cons-head cons-heads) + (declare (ignore cons-head)) + (emit-invokespecial-init + +lisp-cons-class+ (lisp-object-arg-types 2))) + (if list-star-p + (progn + (apply #'maybe-emit-clear-values args) + (emit-move-from-stack target representation)) + (progn + (unless (every 'single-valued-p args) + (emit-clear-values)) + (emit-move-from-stack target)))) + (t + (compile-function-call form target representation))))) + + (defun p2-list (form target representation) - (let* ((args (cdr form)) - (len (length args))) - (cond ((> len 4) ; list1() through list9() are defined in Lisp.java. - (compile-function-call form target representation)) - (t - (cond ((zerop len) - (emit-push-nil)) - ((>= 4 len 1) - (cons-for-list/list* args target representation))) - (unless (every 'single-valued-p args) - (emit-clear-values)) - (emit-move-from-stack target))))) + (cons-for-list/list* form target representation)) (defun p2-list* (form target representation) - (let* ((args (cdr form)) - (length (length args))) - (cond ((>= 4 length 1) - (cons-for-list/list* args target representation t)) - (t - (compile-function-call form target representation))))) + (cons-for-list/list* form target representation t)) (define-inlined-function compile-nth (form target representation) ((check-arg-count form 2)) From vvoutilainen at common-lisp.net Sat May 9 00:15:57 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Fri, 08 May 2009 20:15:57 -0400 Subject: [armedbear-cvs] r11847 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Fri May 8 20:15:55 2009 New Revision: 11847 Log: Clean up duplication for environment restoration and handlers. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 8 20:15:55 2009 @@ -3952,6 +3952,21 @@ +lisp-special-binding+) (astore register)) +(defun restore-environment-and-make-handler (register label-START) + (let ((label-END (gensym)) + (label-EXIT (gensym))) + (emit 'goto label-EXIT) + (label label-END) + (restore-dynamic-environment register) + (emit 'athrow) + ;; Restore dynamic environment. + (label label-EXIT) + (restore-dynamic-environment register) + (push (make-handler :from label-START + :to label-END + :code label-END + :catch-type 0) *handlers*))) + (defun p2-m-v-b-node (block target) (let* ((*blocks* (cons block *blocks*)) (*register* *register*) @@ -3960,9 +3975,7 @@ (vars (second form)) (bind-special-p nil) (variables (block-vars block)) - (label-START (gensym)) - (label-END (gensym)) - (label-EXIT (gensym))) + (label-START (gensym))) (dolist (variable variables) (let ((special-p (variable-special-p variable))) (cond (special-p @@ -4035,18 +4048,8 @@ ;; Body. (compile-progn-body (cdddr form) target) (when bind-special-p - (emit 'goto label-EXIT) - (label label-END) - (restore-dynamic-environment (block-environment-register block)) - (emit 'athrow) - - ;; Restore dynamic environment. - (label label-EXIT) - (restore-dynamic-environment (block-environment-register block)) - (push (make-handler :from label-START - :to label-END - :code label-END - :catch-type 0) *handlers*)))) + (restore-environment-and-make-handler (block-environment-register block) + label-START)))) (defun propagate-vars (block) (let ((removed '())) @@ -4358,9 +4361,7 @@ (form (block-form block)) (*visible-variables* *visible-variables*) (specialp nil) - (label-START (gensym)) - (label-END (gensym)) - (label-EXIT (gensym))) + (label-START (gensym))) ;; Walk the variable list looking for special bindings and unused lexicals. (dolist (variable (block-vars block)) (cond ((variable-special-p variable) @@ -4387,18 +4388,8 @@ (process-optimization-declarations (cddr form)) (compile-progn-body (cddr form) target representation)) (when specialp - (emit 'goto label-EXIT) - (label label-END) - ;; Restore dynamic environment. - (restore-dynamic-environment (block-environment-register block)) - (emit 'athrow) - - (label label-EXIT) - (restore-dynamic-environment (block-environment-register block)) - (push (make-handler :from label-START - :to label-END - :code label-END - :catch-type 0) *handlers*)))) + (restore-environment-and-make-handler (block-environment-register block) + label-START)))) (defun p2-locally (form target representation) (with-saved-compiler-policy @@ -4772,15 +4763,14 @@ (compile-constant (eval (second form)) target representation)))) (defun p2-progv-node (block target representation) + (declare (ignore representation)) (let* ((form (block-form block)) (symbols-form (cadr form)) (values-form (caddr form)) (*register* *register*) (environment-register (setf (block-environment-register block) (allocate-register))) - (label-START (gensym)) - (label-END (gensym)) - (label-EXIT (gensym))) + (label-START (gensym))) (compile-form symbols-form 'stack nil) (compile-form values-form 'stack nil) (unless (and (single-valued-p symbols-form) @@ -4794,20 +4784,8 @@ (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) ;; Implicit PROGN. (let ((*blocks* (cons block *blocks*))) - (compile-progn-body (cdddr form) target) - (emit 'goto label-EXIT) - (label label-END) - (restore-dynamic-environment environment-register) - (emit 'athrow)) - - ;; Restore dynamic environment. - (label label-EXIT) - (restore-dynamic-environment environment-register) - (fix-boxing representation nil) - (push (make-handler :from label-START - :to label-END - :code label-END - :catch-type 0) *handlers*))) + (compile-progn-body (cdddr form) target)) + (restore-environment-and-make-handler environment-register label-START))) (defun p2-quote (form target representation) (aver (or (null representation) (eq representation :boolean))) @@ -8086,9 +8064,7 @@ (*thread* nil) (*initialize-thread-var* nil) (super nil) - (label-START (gensym)) - (label-END (gensym)) - (label-EXIT (gensym))) + (label-START (gensym))) (dolist (var (compiland-arg-vars compiland)) (push var *visible-variables*)) @@ -8245,18 +8221,8 @@ (compile-progn-body body 'stack) (when (compiland-environment-register compiland) - (emit 'goto label-EXIT) - (label label-END) - (restore-dynamic-environment (compiland-environment-register compiland)) - (emit 'athrow) - - ;; Restore dynamic environment - (label label-EXIT) - (restore-dynamic-environment (compiland-environment-register compiland)) - (push (make-handler :from label-START - :to label-END - :code label-END - :catch-type 0) *handlers*)) + (restore-environment-and-make-handler + (compiland-environment-register compiland) label-START)) (unless *code* (emit-push-nil)) From ehuelsmann at common-lisp.net Sat May 9 18:01:59 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 May 2009 14:01:59 -0400 Subject: [armedbear-cvs] r11848 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 9 14:01:56 2009 New Revision: 11848 Log: Eliminate style warnings for variables LOCALLY DECLAREd SPECIAL, by letting the compiler know about the declaration. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sat May 9 14:01:56 2009 @@ -239,7 +239,12 @@ (multiple-value-bind (forms decls) (parse-body (cdr form) nil) (process-optimization-declarations decls) - (process-toplevel-progn forms stream compile-time-too) + (let* ((jvm::*visible-variables* jvm::*visible-variables*) + (specials (process-special-declarations decls))) + (dolist (special specials) + (push (jvm::make-variable :name special :special-p t) + jvm::*visible-variables*)) + (process-toplevel-progn forms stream compile-time-too)) (return-from process-toplevel-form)))) (PROGN (process-toplevel-progn (cdr form) stream compile-time-too) From ehuelsmann at common-lisp.net Sat May 9 18:07:36 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 May 2009 14:07:36 -0400 Subject: [armedbear-cvs] r11849 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 9 14:07:35 2009 New Revision: 11849 Log: Change compiler warning to include action taken (undefined variable, taken to be a special variable). Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat May 9 14:07:35 2009 @@ -947,7 +947,8 @@ (when (null variable) (unless (or (special-variable-p form) (memq form *undefined-variables*)) - (compiler-style-warn "Undefined variable: ~S" form) + (compiler-style-warn + "Undefined variable ~S assumed special" form) (push form *undefined-variables*)) (setf variable (make-variable :name form :special-p t)) (push variable *visible-variables*)) From ehuelsmann at common-lisp.net Sat May 9 18:33:33 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 May 2009 14:33:33 -0400 Subject: [armedbear-cvs] r11850 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 9 14:33:32 2009 New Revision: 11850 Log: p1-lambda: Rewrite the lambda list before bailing out, instead of bailing out before rewriting. This resolves compiler errors in LAMBDA.* ANSI tests. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat May 9 14:33:32 2009 @@ -701,6 +701,7 @@ form)))) (defun p1-lambda (form) + (setf form (rewrite-lambda form)) (let* ((lambda-list (cadr form))) (when (or (memq '&optional lambda-list) (memq '&key lambda-list)) @@ -713,8 +714,7 @@ (not (constantp (second arg)))) (compiler-unsupported "P1-LAMBDA: can't handle optional argument with non-constant initform."))))))) - (p1-function (list 'FUNCTION - (rewrite-lambda form))))) + (p1-function (list 'FUNCTION form)))) (defun p1-eval-when (form) (list* (car form) (cadr form) (mapcar #'p1 (cddr form)))) From ehuelsmann at common-lisp.net Sat May 9 20:05:27 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 May 2009 16:05:27 -0400 Subject: [armedbear-cvs] r11851 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 9 16:05:25 2009 New Revision: 11851 Log: Local transfer of control with environment restoration efficiency: don't save the environment on each block/tagbody start. Only restore the environment when restoration is required, using the value in the outermost block which saved an environment. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat May 9 16:05:25 2009 @@ -4411,26 +4411,11 @@ (BEGIN-BLOCK (gensym)) (END-BLOCK (gensym)) (EXIT (gensym)) - (must-clear-values nil) - environment-register) - (when (block-needs-environment-restoration block) - (setf environment-register (allocate-register) - (block-environment-register block) environment-register)) + (must-clear-values nil)) ;; Scan for tags. (dolist (tag (block-tags block)) (push tag *visible-tags*)) - (when environment-register - ;; Note: we store the environment register, - ;; but since we don't manipulate the environment, - ;; we don't need to restore. - ;; - ;; It's here so local transfers of control can restore - ;; what we started with. - ;; - ;; Non-local transfers of control restore the environment - ;; themselves (in the finally of LET/LET*, etc. - (save-dynamic-environment environment-register)) (label BEGIN-BLOCK) (do* ((rest body (cdr rest)) (subform (car rest) (car rest))) @@ -4509,9 +4494,10 @@ (not (enclosed-by-protected-block-p tag-block))) ;; Local case with local transfer of control ;; Note: Local case with non-local transfer of control handled below - (when (block-environment-register tag-block) + (when (and (block-needs-environment-restoration tag-block) + (enclosed-by-environment-setting-block-p tag-block)) ;; If there's a dynamic environment to restore, do it. - (restore-dynamic-environment (block-environment-register tag-block))) + (restore-dynamic-environment (environment-register-to-restore tag-block))) (maybe-generate-interrupt-check) (emit 'goto (tag-label tag)) (return-from p2-go)) @@ -4619,10 +4605,6 @@ (dformat t "p2-block-node lastSpecialBinding~%") (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) - (when (block-needs-environment-restoration block) - ;; Save the current dynamic environment. - (setf (block-environment-register block) (allocate-register)) - (save-dynamic-environment (block-environment-register block))) (setf (block-catch-tag block) (gensym)) (let* ((*register* *register*) (BEGIN-BLOCK (gensym)) @@ -4657,9 +4639,6 @@ :catch-type (pool-class +lisp-return-class+)) *handlers*))) (label BLOCK-EXIT)) - (when (block-environment-register block) - ;; We saved the dynamic environment above. Restore it now. - (restore-dynamic-environment (block-environment-register block))) (fix-boxing representation nil))))) (defknown p2-return-from (t t t) t) @@ -4681,6 +4660,9 @@ ;; (compiland-name *current-compiland*)) (emit-clear-values)) (compile-form result-form (block-target block) nil) + (when (and (block-needs-environment-restoration block) + (enclosed-by-environment-setting-block-p block)) + (restore-dynamic-environment (environment-register-to-restore block))) (emit 'goto (block-exit block)) (return-from p2-return-from)))) ;; Non-local RETURN. Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat May 9 16:05:25 2009 @@ -427,6 +427,20 @@ (not (block-needs-environment-restoration enclosing-block))) (return t)))) +(defknown environment-register-to-restore (&optional t) t) +(defun environment-register-to-restore (&optional outermost-block) + "Returns the environment register which contains the +saved environment from the outermost enclosing block: + +That's the one which contains the environment used in the outermost block." + (flet ((outermost-register (last-register block) + (when (eq block outermost-block) + (return-from environment-register-to-restore last-register)) + (or (block-environment-register block) + last-register))) + (reduce #'outermost-register *blocks* + :initial-value nil))) + (defstruct tag ;; The symbol (or integer) naming the tag name From vvoutilainen at common-lisp.net Sun May 10 11:47:32 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 10 May 2009 07:47:32 -0400 Subject: [armedbear-cvs] r11852 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun May 10 07:47:29 2009 New Revision: 11852 Log: Combine derive-type flets into a helper function. 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 May 10 07:47:29 2009 @@ -6165,6 +6165,12 @@ (values (and low1 low2 (- low1 low2)) (and high1 high2 (- high1 high2)))) +(defun derive-compiler-types (args op) + (flet ((combine (x y) + (derive-type-numeric-op op x y))) + (reduce #'combine (cdr args) :key #'derive-compiler-type + :initial-value (derive-compiler-type (car args))))) + (defknown derive-type-minus (t) t) (defun derive-type-minus (form) (let ((op (car form)) @@ -6173,11 +6179,7 @@ (1 (derive-type-numeric-op (car form) zero-integer-type (derive-compiler-type (%car args)))) - (2 (flet ((combine (x y) - (derive-type-numeric-op op x y))) - (reduce #'combine (cdr args) :key #'derive-compiler-type - :initial-value (derive-compiler-type (car args)))))))) - + (2 (derive-compiler-types args op))))) (define-int-bounds-derivation + (low1 high1 low2 high2) (values (and low1 low2 (+ low1 low2)) @@ -6189,10 +6191,7 @@ (args (cdr form))) (if (null args) zero-integer-type - (flet ((combine (x y) - (derive-type-numeric-op op x y))) - (reduce #'combine (cdr args) :key #'derive-compiler-type - :initial-value (derive-compiler-type (car args))))))) + (derive-compiler-types args op)))) (define-int-bounds-derivation * (low1 high1 low2 high2) (cond ((or (null low1) (null low2)) @@ -6218,10 +6217,7 @@ (args (cdr form))) (if (null args) one-integer-type - (flet ((combine (x y) - (derive-type-numeric-op op x y))) - (reduce #'combine (cdr args) :key #'derive-compiler-type - :initial-value (derive-compiler-type (car args))))))) + (derive-compiler-types args op)))) (define-int-bounds-derivation max (low1 low2 high1 high2) (values (or (when (and low1 low2) (max low1 low2)) low1 low2) @@ -6231,10 +6227,7 @@ (defun derive-type-max (form) (let ((op (car form)) (args (cdr form))) - (flet ((combine (x y) - (derive-type-numeric-op op x y))) - (reduce #'combine (cdr args) :key #'derive-compiler-type - :initial-value (derive-compiler-type (car args)))))) + (derive-compiler-types args op))) (define-int-bounds-derivation min (low1 high1 low2 high2) (values (or (when (and low1 low2) (min low1 low2)) low1 low2) @@ -6244,10 +6237,7 @@ (defun derive-type-min (form) (let ((op (car form)) (args (cdr form))) - (flet ((combine (x y) - (derive-type-numeric-op op x y))) - (reduce #'combine (cdr args) :key #'derive-compiler-type - :initial-value (derive-compiler-type (car args)))))) + (derive-compiler-types args op))) ;; read-char &optional input-stream eof-error-p eof-value recursive-p => char (declaim (ftype (function (t) t) derive-type-read-char)) From ehuelsmann at common-lisp.net Sun May 10 21:21:47 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 10 May 2009 17:21:47 -0400 Subject: [armedbear-cvs] r11853 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 10 17:21:44 2009 New Revision: 11853 Log: Restore closure variables from their saved values, in case of a non-local transfer of control (ie, a Java exception), such as GO or RETURN-FROM in the callee. 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 May 10 17:21:44 2009 @@ -3020,7 +3020,10 @@ (args (cdr form)) (local-function (find-local-function op)) (*register* *register*) - (saved-vars '())) + (saved-vars '()) + (label-START (gensym)) + (label-END (gensym)) + (label-EXIT (gensym))) (cond ((local-function-variable local-function) ;; LABELS (dformat t "compile-local-function-call LABELS case variable = ~S~%" @@ -3031,6 +3034,8 @@ (compiland-arg-vars (local-function-compiland local-function)) *visible-variables*)))) ;; (emit 'var-ref (local-function-variable local-function) 'stack) + (when saved-vars + (label label-START)) (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)) (t (dformat t "compile-local-function-call default case~%") @@ -3049,7 +3054,16 @@ (fix-boxing representation nil) (emit-move-from-stack target representation) (when saved-vars - (restore-variables saved-vars))) + (emit 'goto label-EXIT) + (label label-END) + (restore-variables saved-vars) + (emit 'athrow) + (label label-EXIT) + (restore-variables saved-vars) + (push (make-handler :from label-START + :to label-END + :code label-END + :catch-type 0) *handlers*))) t) From ehuelsmann at common-lisp.net Mon May 11 19:40:12 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 11 May 2009 15:40:12 -0400 Subject: [armedbear-cvs] r11854 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 11 15:40:10 2009 New Revision: 11854 Log: P2-COMPILAND: baby step at cleaning up for readability. 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 Mon May 11 15:40:10 2009 @@ -8042,8 +8042,8 @@ (execute-method (make-method :name execute-method-name :descriptor descriptor)) (*code* ()) - (*register* 0) - (*registers-allocated* 0) + (*register* 1) ;; register 0: "this" pointer + (*registers-allocated* 1) (*handlers* ()) (*visible-variables* *visible-variables*) @@ -8061,34 +8061,29 @@ (pool-name (method-name execute-method))) (setf (method-descriptor-index execute-method) (pool-name (method-descriptor execute-method))) - (cond (*hairy-arglist-p* - (let ((index 0)) - (dolist (variable (compiland-arg-vars compiland)) - (aver (null (variable-register variable))) - (aver (null (variable-index variable))) - (setf (variable-index variable) index) - (incf index)))) - (t - (let ((register (if (and *closure-variables* *child-p*) - 2 ; Reg 1 is reserved for closure variables array. - 1)) - (index 0)) - (dolist (variable (compiland-arg-vars compiland)) - (aver (null (variable-register variable))) - (setf (variable-register variable) - (if *using-arg-array* nil register)) - (aver (null (variable-index variable))) - (if *using-arg-array* - (setf (variable-index variable) index)) - (incf register) - (incf index))))) - - (p2-compiland-process-type-declarations body) - (allocate-register) ;; register 0: "this" pointer (when (and *closure-variables* *child-p*) - (setf (compiland-closure-register compiland) (allocate-register)) ;; register 1 - (dformat t "p2-compiland 1 closure register = ~S~%" (compiland-closure-register compiland))) + (setf (compiland-closure-register compiland) + (allocate-register)) ;; register 1: the closure array + (dformat t "p2-compiland 1 closure register = ~S~%" + (compiland-closure-register compiland))) + + + (let ((register *register*) + (index 0)) + (dolist (variable (compiland-arg-vars compiland)) + (aver (null (variable-register variable))) + (aver (null (variable-index variable))) + (cond + (*hairy-arglist-p* + (setf (variable-index variable) index)) + (*using-arg-array* + (setf (variable-index variable) index)) + (t + (setf (variable-register variable) register))) + (incf register) + (incf index))) + (cond (*using-arg-array* ;; One slot for arg array. (setf (compiland-argument-register compiland) (allocate-register)) @@ -8099,15 +8094,21 @@ (aver (null (variable-register variable))) (aver (null (variable-reserved-register variable))) (unless (variable-special-p variable) - (setf (variable-reserved-register variable) (allocate-register)))))) + (setf (variable-reserved-register variable) + (allocate-register)))))) (t ;; Otherwise, one register for each argument. (dolist (variable (compiland-arg-vars compiland)) (declare (ignore variable)) (allocate-register)))) + + (p2-compiland-process-type-declarations body) + + (when (and *closure-variables* (not *child-p*)) (setf (compiland-closure-register compiland) (allocate-register)) - (dformat t "p2-compiland 2 closure register = ~S~%" (compiland-closure-register compiland))) + (dformat t "p2-compiland 2 closure register = ~S~%" + (compiland-closure-register compiland))) ;; Reserve the next available slot for the thread register. (setf *thread* (allocate-register)) From ehuelsmann at common-lisp.net Mon May 11 20:32:23 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 11 May 2009 16:32:23 -0400 Subject: [armedbear-cvs] r11855 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 11 16:32:22 2009 New Revision: 11855 Log: Further simplification of the little planet that's called P2-COMPILAND. 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 Mon May 11 16:32:22 2009 @@ -8030,9 +8030,12 @@ (class-file (compiland-class-file compiland)) (*this-class* (class-file-class class-file)) (args (cadr p1-result)) + (closure-args (intersection *closure-variables* + (compiland-arg-vars compiland))) (body (cddr p1-result)) (*using-arg-array* nil) (*hairy-arglist-p* nil) + ;; *hairy-arglist-p* != NIL --> *using-arglist-array* != NIL (*child-p* (not (null (compiland-parent compiland)))) @@ -8068,39 +8071,29 @@ (dformat t "p2-compiland 1 closure register = ~S~%" (compiland-closure-register compiland))) + (when *using-arg-array* + (setf (compiland-argument-register compiland) (allocate-register))) - (let ((register *register*) - (index 0)) + ;; Assign indices or registers, depending on where the args are + ;; located: the arg-array or the call-stack + (let ((index 0)) (dolist (variable (compiland-arg-vars compiland)) (aver (null (variable-register variable))) (aver (null (variable-index variable))) - (cond - (*hairy-arglist-p* - (setf (variable-index variable) index)) - (*using-arg-array* - (setf (variable-index variable) index)) - (t - (setf (variable-register variable) register))) - (incf register) + (if *using-arg-array* + (setf (variable-index variable) index) + (setf (variable-register variable) (allocate-register))) (incf index))) - (cond (*using-arg-array* - ;; One slot for arg array. - (setf (compiland-argument-register compiland) (allocate-register)) - - (unless (or *closure-variables* *child-p*) - ;; Reserve a register for each parameter. - (dolist (variable (compiland-arg-vars compiland)) - (aver (null (variable-register variable))) - (aver (null (variable-reserved-register variable))) - (unless (variable-special-p variable) - (setf (variable-reserved-register variable) - (allocate-register)))))) - (t - ;; Otherwise, one register for each argument. - (dolist (variable (compiland-arg-vars compiland)) - (declare (ignore variable)) - (allocate-register)))) + (when (and *using-arg-array* + (not (or *closure-variables* *child-p*))) + ;; Reserve a register for each parameter. + (dolist (variable (compiland-arg-vars compiland)) + (aver (null (variable-register variable))) + (aver (null (variable-reserved-register variable))) + (unless (variable-special-p variable) + (setf (variable-reserved-register variable) + (allocate-register))))) (p2-compiland-process-type-declarations body) @@ -8119,41 +8112,41 @@ (compiland-name compiland)) (cond (*child-p* (aver (eql (compiland-closure-register compiland) 1)) - (when (some #'variable-closure-index - (compiland-arg-vars compiland)) + (when closure-args (aload (compiland-closure-register compiland)))) (t (emit-push-constant-int (length *closure-variables*)) (dformat t "p2-compiland ~S anewarray 1~%" (compiland-name compiland)) (emit 'anewarray "org/armedbear/lisp/LispObject"))) - (dolist (variable (compiland-arg-vars compiland)) + (dolist (variable closure-args) (dformat t "considering ~S ...~%" (variable-name variable)) - (when (variable-closure-index variable) - (dformat t "moving variable ~S~%" (variable-name variable)) - (cond ((variable-register variable) - (when (eql (variable-register variable) - (compiland-closure-register compiland)) - (error "ERROR! compiland closure register = ~S var ~S register = ~S~%" - (compiland-closure-register compiland) - (variable-name variable) - (variable-register variable))) - (emit 'dup) ; array - (emit-push-constant-int (variable-closure-index variable)) - (aload (variable-register variable)) - (emit 'aastore) - (setf (variable-register variable) nil)) ; The variable has moved. - ((variable-index variable) - (emit 'dup) ; array - (emit-push-constant-int (variable-closure-index variable)) - (aload (compiland-argument-register compiland)) - (emit-push-constant-int (variable-index variable)) - (emit 'aaload) - (emit 'aastore) - (setf (variable-index variable) nil))))) ; The variable has moved. + (dformat t "moving variable ~S~%" (variable-name variable)) + (cond ((variable-register variable) + (when (eql (variable-register variable) + (compiland-closure-register compiland)) + (error "ERROR! compiland closure register = ~S var ~S register = ~S~%" + (compiland-closure-register compiland) + (variable-name variable) + (variable-register variable))) + (emit 'dup) ; array + (emit-push-constant-int (variable-closure-index variable)) + (aload (variable-register variable)) + (emit 'aastore) + (setf (variable-register variable) nil)) + ;; The variable has moved. + ((variable-index variable) + (emit 'dup) ; array + (emit-push-constant-int (variable-closure-index variable)) + (aload (compiland-argument-register compiland)) + (emit-push-constant-int (variable-index variable)) + (emit 'aaload) + (emit 'aastore) + (setf (variable-index variable) nil)))) + ;; The variable has moved. + (aver (not (null (compiland-closure-register compiland)))) (cond (*child-p* - (when (some #'variable-closure-index - (compiland-arg-vars compiland)) + (when closure-args (emit 'pop))) (t (astore (compiland-closure-register compiland)))) From astalla at common-lisp.net Mon May 11 21:12:19 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 11 May 2009 17:12:19 -0400 Subject: [armedbear-cvs] r11856 - in trunk/abcl: examples/abcl/jsr-223 src/org/armedbear/lisp src/org/armedbear/lisp/scripting/lisp Message-ID: Author: astalla Date: Mon May 11 17:12:17 2009 New Revision: 11856 Log: * loading: added a new primitive sys::load-returning-last-result which behaves like load but returns the last value produced instead of T * JSR-223: - used the new load-returning-last-result to evaluate both interpreted and compiled code for consistency (with a caveat, see the wiki page on JSR-223) - bindings established through ScriptContext are now declared special - compilation using the runtime compiler has been removed due to inconsistencies with evaluation and file-based compilation - updated the example as suggested on the ML to show both modes of getting the AbclScriptEngine Modified: trunk/abcl/examples/abcl/jsr-223/JSR223Example.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/load.lisp trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp Modified: trunk/abcl/examples/abcl/jsr-223/JSR223Example.java ============================================================================== --- trunk/abcl/examples/abcl/jsr-223/JSR223Example.java (original) +++ trunk/abcl/examples/abcl/jsr-223/JSR223Example.java Mon May 11 17:12:17 2009 @@ -3,8 +3,19 @@ public class JSR223Example { public static void main(String[] args) { - //Script Engine instantiation - ScriptEngine lispEngine = new ScriptEngineManager().getEngineByExtension("lisp"); + //Script Engine instantiation using ServiceProvider - this will + //look in the classpath for a file + // /META-INF/services/javax.script.ScriptEngineFactory + //where the AbclScriptEngineFactory is registered + ScriptEngine lispEngine = new ScriptEngineManager().getEngineByExtension("lisp"); + + //Alternatively, you can directly instantiate the script engine: + + //ScriptEngineManager scriptManager = new ScriptEngineManager(); + //scriptManager.registerEngineExtension("lisp", new AbclScriptEngineFactory()); + //ScriptEngine lispEngine = scriptManager.getEngineByExtension("lisp"); + + //(thanks to Peter Tsenter for suggesting this) //Accessing variables System.out.println(); Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Mon May 11 17:12:17 2009 @@ -90,6 +90,17 @@ boolean verbose, boolean print, boolean ifDoesNotExist) + throws ConditionThrowable { + 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) throws ConditionThrowable { String dir = null; @@ -153,7 +164,7 @@ try { return loadFileFromStream(null, truename, new Stream(in, Symbol.CHARACTER), - verbose, print, false); + verbose, print, false, returnLastResult); } catch (FaslVersionMismatch e) { FastStringBuffer sb = @@ -380,6 +391,17 @@ boolean verbose, boolean print, boolean auto) + throws ConditionThrowable { + return loadFileFromStream(pathname, truename, in, verbose, print, auto, false); + } + + private static final LispObject loadFileFromStream(LispObject pathname, + String truename, + Stream in, + boolean verbose, + boolean print, + boolean auto, + boolean returnLastResult) throws ConditionThrowable { long start = System.currentTimeMillis(); @@ -415,7 +437,7 @@ out._writeString(truename != null ? truename : "stream"); out._writeLine(" ..."); out._finishOutput(); - LispObject result = loadStream(in, print, thread); + LispObject result = loadStream(in, print, thread, returnLastResult); long elapsed = System.currentTimeMillis() - start; out.freshLine(); out._writeString(prefix); @@ -427,7 +449,7 @@ out._finishOutput(); return result; } else - return loadStream(in, print, thread); + return loadStream(in, print, thread, returnLastResult); } finally { thread.lastSpecialBinding = lastSpecialBinding; @@ -444,6 +466,12 @@ private static final LispObject loadStream(Stream in, boolean print, LispThread thread) + throws ConditionThrowable { + return loadStream(in, print, thread, false); + } + + private static final LispObject loadStream(Stream in, boolean print, + LispThread thread, boolean returnLastResult) throws ConditionThrowable { SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; @@ -454,12 +482,13 @@ thread.lastSpecialBinding = sourcePositionBinding; try { final Environment env = new Environment(); + LispObject result = NIL; while (true) { sourcePositionBinding.value = Fixnum.getInstance(in.getOffset()); LispObject obj = in.read(false, EOF, false, thread); if (obj == EOF) break; - LispObject result = eval(obj, env, thread); + result = eval(obj, env, thread); if (print) { Stream out = checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread)); @@ -467,7 +496,11 @@ out._finishOutput(); } } - return T; + if(returnLastResult) { + return result; + } else { + return T; + } } finally { thread.lastSpecialBinding = lastSpecialBinding; @@ -480,19 +513,24 @@ Stream in = (Stream) _LOAD_STREAM_.symbolValue(thread); final Environment env = new Environment(); final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + LispObject result = NIL; try { thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package()); while (true) { LispObject obj = in.faslRead(false, EOF, true, thread); if (obj == EOF) break; - eval(obj, env, thread); + result = eval(obj, env, thread); } } finally { thread.lastSpecialBinding = lastSpecialBinding; } - return T; + 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. } // Returns extension including leading '.' @@ -562,41 +600,64 @@ { @Override public LispObject execute(LispObject filespec, LispObject verbose, - LispObject print, LispObject ifDoesNotExist) - 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); - } - // 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); - } + 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 + private static final Primitive _LOAD_RETURNING_LAST_RESULT = + new Primitive("%load-returning-last-result", PACKAGE_SYS, false, + "filespec verbose print if-does-not-exist") + { + @Override + public LispObject execute(LispObject filespec, LispObject verbose, + 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); + } + // ### load-system-file private static final Primitive LOAD_SYSTEM_FILE = new Primitive("load-system-file", PACKAGE_SYS, true) Modified: trunk/abcl/src/org/armedbear/lisp/load.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/load.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/load.lisp Mon May 11 17:12:17 2009 @@ -42,3 +42,15 @@ filespec (merge-pathnames (pathname filespec))) verbose print if-does-not-exist)) + +(defun load-returning-last-result (filespec + &key + (verbose *load-verbose*) + (print *load-print*) + (if-does-not-exist t) + (external-format :default)) + (declare (ignore external-format)) ; FIXME + (%load-returning-last-result (if (streamp filespec) + filespec + (merge-pathnames (pathname filespec))) + verbose print if-does-not-exist)) \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp Mon May 11 17:12:17 2009 @@ -51,6 +51,12 @@ (cdr binding))) bindings))) +(defun generate-special-declarations (bindings) + (let ((*package* (find-package :abcl-script-user))) + `(declare (special + ,@(mapcar (lambda (binding) (read-from-string (car binding))) + bindings))))) + (defun generate-java-bindings (bindings-list actual-bindings java-bindings) (loop :for binding :in actual-bindings :for jbinding :in bindings-list @@ -72,6 +78,8 @@ (,actual-engine-bindings (generate-bindings ,engine-bindings))) (eval `(let (,@,actual-global-bindings) (let (,@,actual-engine-bindings) + ,(generate-special-declarations ,global-bindings) + ,(generate-special-declarations ,engine-bindings) (prog1 (progn ,@,body) (finish-output *standard-output*) @@ -87,8 +95,8 @@ (defun eval-script (global-bindings engine-bindings stdin stdout code-string script-context) (eval-in-script-context (global-bindings engine-bindings stdin stdout script-context) - (read-from-string - (concatenate 'string "(" code-string ")")))) + `((with-input-from-string (str ,code-string) + (sys::load-returning-last-result str))))) (defun eval-compiled-script (global-bindings engine-bindings stdin stdout function script-context) @@ -96,32 +104,24 @@ `((funcall ,function)))) (defun compile-script (code-string) - (if *compile-using-temp-files* - (let* ((tmp-file (jstatic (jmethod "java.io.File" "createTempFile" "java.lang.String" "java.lang.String") - nil "abcl-src-file-" ".lisp")) - (tmp-file-path (jcall (jmethod "java.io.File" "getAbsolutePath") tmp-file))) - (jcall (jmethod "java.io.File" "deleteOnExit") tmp-file) ;to be really-really-really sure... - (unwind-protect - (progn - (with-open-file (stream tmp-file-path :direction :output) - (princ "(in-package :abcl-script-user)" stream) - (princ code-string stream) - (finish-output stream)) - (let ((compiled-file (compile-file tmp-file-path))) - (jcall (jmethod "java.io.File" "deleteOnExit") - (jnew (jconstructor "java.io.File" "java.lang.String") - (namestring compiled-file))) - (lambda () - (let ((*package* (find-package :abcl-script-user))) - (load compiled-file :verbose t :print t))))) - (delete-file tmp-file-path))) - (eval - `(compile - nil - (lambda () - ,@(let ((*package* (find-package :abcl-script-user))) - (read-from-string - (concatenate 'string "(" code-string " cl:t)")))))))) ;return T in conformity of what LOAD does. + (let* ((tmp-file (jstatic (jmethod "java.io.File" "createTempFile" "java.lang.String" "java.lang.String") + nil "abcl-src-file-" ".lisp")) + (tmp-file-path (jcall (jmethod "java.io.File" "getAbsolutePath") tmp-file))) + (jcall (jmethod "java.io.File" "deleteOnExit") tmp-file) ;to be really-really-really sure... + (unwind-protect + (progn + (with-open-file (stream tmp-file-path :direction :output) + (princ "(in-package :abcl-script-user)" stream) + (princ code-string stream) + (finish-output stream)) + (let ((compiled-file (compile-file tmp-file-path))) + (jcall (jmethod "java.io.File" "deleteOnExit") + (jnew (jconstructor "java.io.File" "java.lang.String") + (namestring compiled-file))) + (lambda () + (let ((*package* (find-package :abcl-script-user))) + (sys::load-returning-last-result compiled-file))))) + (delete-file tmp-file-path)))) ;;Java interface implementation - TODO Modified: trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp Mon May 11 17:12:17 2009 @@ -39,8 +39,6 @@ (defparameter *use-throwing-debugger* t) -(defparameter *compile-using-temp-files* t) - (defun configure-abcl (abcl-script-engine) (when *launch-swank-at-startup* (unless *swank-dir* From ehuelsmann at common-lisp.net Mon May 11 21:38:50 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 11 May 2009 17:38:50 -0400 Subject: [armedbear-cvs] r11857 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 11 17:38:49 2009 New Revision: 11857 Log: P2-COMPILAND: Code re-ordering and merging of blocks with the same conditions. 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 Mon May 11 17:38:49 2009 @@ -8085,55 +8085,37 @@ (setf (variable-register variable) (allocate-register))) (incf index))) - (when (and *using-arg-array* - (not (or *closure-variables* *child-p*))) - ;; Reserve a register for each parameter. - (dolist (variable (compiland-arg-vars compiland)) - (aver (null (variable-register variable))) - (aver (null (variable-reserved-register variable))) - (unless (variable-special-p variable) - (setf (variable-reserved-register variable) - (allocate-register))))) - - (p2-compiland-process-type-declarations body) - + ;; Reserve the next available slot for the thread register. + (setf *thread* (allocate-register)) (when (and *closure-variables* (not *child-p*)) (setf (compiland-closure-register compiland) (allocate-register)) (dformat t "p2-compiland 2 closure register = ~S~%" (compiland-closure-register compiland))) - ;; Reserve the next available slot for the thread register. - (setf *thread* (allocate-register)) - ;; Move args from their original registers to the closure variables array, - ;; if applicable. - (when *closure-variables* - (dformat t "~S moving arguments to closure array (if applicable)~%" + ;; Move args from their original registers to the closure variables array + (when (or closure-args + (and *closure-variables* (not *child-p*))) + (dformat t "~S moving arguments to closure array~%" (compiland-name compiland)) (cond (*child-p* (aver (eql (compiland-closure-register compiland) 1)) - (when closure-args - (aload (compiland-closure-register compiland)))) - (t + (aload (compiland-closure-register compiland))) + (t ;; if we're the ultimate parent: create the closure array (emit-push-constant-int (length *closure-variables*)) - (dformat t "p2-compiland ~S anewarray 1~%" (compiland-name compiland)) + (dformat t "p2-compiland ~S anewarray 1~%" + (compiland-name compiland)) (emit 'anewarray "org/armedbear/lisp/LispObject"))) (dolist (variable closure-args) - (dformat t "considering ~S ...~%" (variable-name variable)) (dformat t "moving variable ~S~%" (variable-name variable)) (cond ((variable-register variable) - (when (eql (variable-register variable) - (compiland-closure-register compiland)) - (error "ERROR! compiland closure register = ~S var ~S register = ~S~%" - (compiland-closure-register compiland) - (variable-name variable) - (variable-register variable))) + (assert (not (eql (variable-register variable) + (compiland-closure-register compiland)))) (emit 'dup) ; array (emit-push-constant-int (variable-closure-index variable)) (aload (variable-register variable)) (emit 'aastore) (setf (variable-register variable) nil)) - ;; The variable has moved. ((variable-index variable) (emit 'dup) ; array (emit-push-constant-int (variable-closure-index variable)) @@ -8142,30 +8124,29 @@ (emit 'aaload) (emit 'aastore) (setf (variable-index variable) nil)))) - ;; The variable has moved. (aver (not (null (compiland-closure-register compiland)))) (cond (*child-p* - (when closure-args - (emit 'pop))) + (emit 'pop)) (t (astore (compiland-closure-register compiland)))) (dformat t "~S done moving arguments to closure array~%" (compiland-name compiland))) ;; If applicable, move args from arg array to registers. - (when *using-arg-array* - (unless (or *closure-variables* *child-p*) - (dolist (variable (compiland-arg-vars compiland)) - (when (variable-reserved-register variable) - (aver (not (variable-special-p variable))) + (when (and *using-arg-array* + (not (or *closure-variables* *child-p*))) + (dolist (variable (compiland-arg-vars compiland)) + (unless (variable-special-p variable) + (let ((register (allocate-register))) (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) (emit 'aaload) - (astore (variable-reserved-register variable)) - (setf (variable-register variable) (variable-reserved-register variable)) + (astore register) + (setf (variable-register variable) register) (setf (variable-index variable) nil))))) + (p2-compiland-process-type-declarations body) (generate-type-checks-for-variables (compiland-arg-vars compiland)) ;; Unbox variables. From astalla at common-lisp.net Wed May 13 18:53:00 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 13 May 2009 14:53:00 -0400 Subject: [armedbear-cvs] r11858 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed May 13 14:52:52 2009 New Revision: 11858 Log: JProxy now uses funcall instead of function.execute(LispObject[]). This allows consistent behavior in interpreted and compiled code. Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JProxy.java Wed May 13 14:52:52 2009 @@ -142,57 +142,60 @@ */ private static final Map proxyMap = new WeakHashMap(); - public static class LispInvocationHandler implements InvocationHandler { - - private Function function; - private static Method hashCodeMethod; - private static Method equalsMethod; - private static Method toStringMethod; - - static { - try { - hashCodeMethod = Object.class.getMethod("hashCode", new Class[] {}); - equalsMethod = Object.class.getMethod("equals", new Class[] { Object.class }); - toStringMethod = Object.class.getMethod("toString", new Class[] {}); - } catch (Exception e) { - throw new Error("Something got horribly wrong - can't get a method from Object.class", e); - } - } - - public LispInvocationHandler(Function function) { - this.function = function; - } + public static class LispInvocationHandler implements InvocationHandler { + + private Function function; + private static Method hashCodeMethod; + private static Method equalsMethod; + private static Method toStringMethod; + + static { + try { + hashCodeMethod = Object.class.getMethod("hashCode", new Class[] {}); + equalsMethod = Object.class.getMethod("equals", new Class[] { Object.class }); + toStringMethod = Object.class.getMethod("toString", new Class[] {}); + } catch (Exception e) { + throw new Error("Something got horribly wrong - can't get a method from Object.class", e); + } + } + + public LispInvocationHandler(Function function) { + this.function = function; + } - public Object invoke(Object proxy, Method method, Object[] args) throws Throwable { - if(hashCodeMethod.equals(method)) { - return System.identityHashCode(proxy); - } - if(equalsMethod.equals(method)) { - return proxy == args[0]; - } - if(toStringMethod.equals(method)) { - return proxy.getClass().getName() + '@' + Integer.toHexString(proxy.hashCode()); - } + public Object invoke(Object proxy, Method method, Object[] args) throws Throwable { + if(hashCodeMethod.equals(method)) { + return System.identityHashCode(proxy); + } + if(equalsMethod.equals(method)) { + return proxy == args[0]; + } + if(toStringMethod.equals(method)) { + return proxy.getClass().getName() + '@' + Integer.toHexString(proxy.hashCode()); + } - if(args == null) { - args = new Object[0]; - } - LispObject[] lispArgs = new LispObject[args.length + 2]; - synchronized(proxyMap) { - lispArgs[0] = toLispObject(proxyMap.get(proxy)); - } - lispArgs[1] = new SimpleString(method.getName()); - for(int i = 0; i < args.length; i++) { - lispArgs[i + 2] = toLispObject(args[i]); - } - Object retVal = (function.execute(lispArgs)).javaInstance(); - /* DOES NOT WORK due to autoboxing! - if(retVal != null && !method.getReturnType().isAssignableFrom(retVal.getClass())) { - return error(new TypeError(new JavaObject(retVal), new JavaObject(method.getReturnType()))); - }*/ - return retVal; - } + if(args == null) { + args = new Object[0]; + } + LispObject[] lispArgs = new LispObject[args.length + 3]; + lispArgs[0] = function; + synchronized(proxyMap) { + lispArgs[1] = toLispObject(proxyMap.get(proxy)); + } + lispArgs[2] = new SimpleString(method.getName()); + for(int i = 0; i < args.length; i++) { + lispArgs[i + 3] = toLispObject(args[i]); + } + Object retVal = + LispThread.currentThread().execute(Symbol.FUNCALL, lispArgs).javaInstance(); + //(function.execute(lispArgs)).javaInstance(); + /* DOES NOT WORK due to autoboxing! + if(retVal != null && !method.getReturnType().isAssignableFrom(retVal.getClass())) { + return error(new TypeError(new JavaObject(retVal), new JavaObject(method.getReturnType()))); + }*/ + return retVal; } + } private static final Primitive _JMAKE_INVOCATION_HANDLER = new Primitive("%jmake-invocation-handler", PACKAGE_JAVA, false, From astalla at common-lisp.net Wed May 13 19:07:12 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 13 May 2009 15:07:12 -0400 Subject: [armedbear-cvs] r11859 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed May 13 15:07:10 2009 New Revision: 11859 Log: Corrected previous commit: JProxy uses APPLY and not FUNCALL. Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JProxy.java Wed May 13 15:07:10 2009 @@ -177,17 +177,17 @@ if(args == null) { args = new Object[0]; } - LispObject[] lispArgs = new LispObject[args.length + 3]; - lispArgs[0] = function; + LispObject lispArgs = NIL; synchronized(proxyMap) { - lispArgs[1] = toLispObject(proxyMap.get(proxy)); + lispArgs = lispArgs.push(toLispObject(proxyMap.get(proxy))); } - lispArgs[2] = new SimpleString(method.getName()); + lispArgs = lispArgs.push(new SimpleString(method.getName())); for(int i = 0; i < args.length; i++) { - lispArgs[i + 3] = toLispObject(args[i]); + lispArgs = lispArgs.push(toLispObject(args[i])); } Object retVal = - LispThread.currentThread().execute(Symbol.FUNCALL, lispArgs).javaInstance(); + LispThread.currentThread().execute + (Symbol.APPLY, function, lispArgs.reverse()).javaInstance(); //(function.execute(lispArgs)).javaInstance(); /* DOES NOT WORK due to autoboxing! if(retVal != null && !method.getReturnType().isAssignableFrom(retVal.getClass())) { From ehuelsmann at common-lisp.net Thu May 14 18:12:23 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 14 May 2009 14:12:23 -0400 Subject: [armedbear-cvs] r11860 - branches/closure-fixes Message-ID: Author: ehuelsmann Date: Thu May 14 14:12:08 2009 New Revision: 11860 Log: Create a place to store my work in progress. Added: branches/closure-fixes/ - copied from r11859, /trunk/ From ehuelsmann at common-lisp.net Thu May 14 18:17:10 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 14 May 2009 14:17:10 -0400 Subject: [armedbear-cvs] r11861 - branches/closure-fixes/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 14 14:17:08 2009 New Revision: 11861 Log: Work in progress on changing the closure array over from variables to bindings. Added: branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureBinding.java (contents, props changed) Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java branches/closure-fixes/abcl/src/org/armedbear/lisp/CompiledClosure.java branches/closure-fixes/abcl/src/org/armedbear/lisp/Lisp.java branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Added: branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureBinding.java ============================================================================== --- (empty file) +++ branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureBinding.java Thu May 14 14:17:08 2009 @@ -0,0 +1,50 @@ +/* + * ClosureBinding.java + * + * Copyright (C) 2009 Erik Huelsmann + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +/** This class serves merely to store a reference to an + * object, used in the closure array. + * + * Objects of this type are used to model the fact that + * closures close over bindings and not over values. + * + */ +public class ClosureBinding +{ + public LispObject value; + + public ClosureBinding(LispObject value) { + this.value = value; + } +} \ No newline at end of file Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java ============================================================================== --- branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java (original) +++ branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Thu May 14 14:17:08 2009 @@ -37,7 +37,7 @@ implements Cloneable { - public LispObject[] ctx; + public ClosureBinding[] ctx; public ClosureTemplateFunction(LispObject lambdaList) throws ConditionThrowable @@ -45,7 +45,7 @@ super(list(Symbol.LAMBDA, lambdaList), null); } - final public ClosureTemplateFunction setContext(LispObject[] context) + final public ClosureTemplateFunction setContext(ClosureBinding[] context) { ctx = context; return this; @@ -156,14 +156,14 @@ // "evaluate this template with these values" // Zero args. - public LispObject _execute(LispObject[] context) throws ConditionThrowable + public LispObject _execute(ClosureBinding[] context) throws ConditionThrowable { LispObject[] args = new LispObject[0]; return _execute(context, args); } // One arg. - public LispObject _execute(LispObject[] context, LispObject first) + public LispObject _execute(ClosureBinding[] context, LispObject first) throws ConditionThrowable { LispObject[] args = new LispObject[1]; @@ -172,7 +172,7 @@ } // Two args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second) throws ConditionThrowable { @@ -183,7 +183,7 @@ } // Three args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third) throws ConditionThrowable { @@ -195,7 +195,7 @@ } // Four args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable @@ -209,7 +209,7 @@ } // Five args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) throws ConditionThrowable @@ -224,7 +224,7 @@ } // Six args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) @@ -241,7 +241,7 @@ } // Seven args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh) @@ -259,7 +259,7 @@ } // Eight args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh, @@ -279,7 +279,7 @@ } // Arg array. - public LispObject _execute(LispObject[] context, LispObject[] args) + public LispObject _execute(ClosureBinding[] context, LispObject[] args) throws ConditionThrowable { return notImplemented(); Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/CompiledClosure.java ============================================================================== --- branches/closure-fixes/abcl/src/org/armedbear/lisp/CompiledClosure.java (original) +++ branches/closure-fixes/abcl/src/org/armedbear/lisp/CompiledClosure.java Thu May 14 14:17:08 2009 @@ -36,9 +36,9 @@ public class CompiledClosure extends Function { private final ClosureTemplateFunction ctf; - private final LispObject[] context; + private final ClosureBinding[] context; - public CompiledClosure(ClosureTemplateFunction ctf, LispObject[] context) + public CompiledClosure(ClosureTemplateFunction ctf, ClosureBinding[] context) { super(ctf.getLambdaName(), ctf.getLambdaList()); this.ctf = ctf; Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/closure-fixes/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ branches/closure-fixes/abcl/src/org/armedbear/lisp/Lisp.java Thu May 14 14:17:08 2009 @@ -1186,7 +1186,7 @@ } public static final LispObject makeCompiledClosure(LispObject template, - LispObject[] context) + ClosureBinding[] context) throws ConditionThrowable { ClosureTemplateFunction ctf = ((ClosureTemplateFunction) template).dup(); Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 14 14:17:08 2009 @@ -205,6 +205,7 @@ (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") +(defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") (defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject") @@ -3047,7 +3048,7 @@ (emit 'checkcast +lisp-ctf-class+) (aload (compiland-closure-register compiland)) (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) + (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) (process-args args) (emit-call-execute (length args)) @@ -3919,6 +3920,10 @@ (emit-invokevirtual +lisp-thread-class+ "bindSpecial" (list +lisp-symbol+ +lisp-object+) nil)) ((variable-closure-index variable) + (emit 'new "org/armedbear/lisp/ClosureBinding") + (emit 'dup) + (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" + (list +lisp-object+)) (aload (compiland-closure-register *current-compiland*)) (emit 'swap) ; array value (emit-push-constant-int (variable-closure-index variable)) @@ -4195,16 +4200,17 @@ (emit-array-store (variable-representation variable))) ((variable-closure-index variable) (aload (compiland-closure-register *current-compiland*)) - (emit-swap representation nil) (emit-push-constant-int (variable-closure-index variable)) - (emit-swap representation :int) - (emit-array-store (variable-representation variable))) + (emit 'aaload) + (emit-swap representation nil) + (emit 'putfield "org/armedbear/lisp/ClosureBinding" "value" + "Lorg/armedbear/lisp/LispObject;")) (t ;;###FIXME: We might want to address the "temp-register" case too. (assert nil)))))) (defun emit-push-variable (variable) - (flet ((emit-array-store (representation) + (flet ((emit-array-load (representation) (emit (ecase representation ((:int :boolean :char) 'iaload) @@ -4224,11 +4230,13 @@ ((variable-index variable) (aload (compiland-argument-register *current-compiland*)) (emit-push-constant-int (variable-index variable)) - (emit-array-store (variable-representation variable))) + (emit-array-load (variable-representation variable))) ((variable-closure-index variable) (aload (compiland-closure-register *current-compiland*)) (emit-push-constant-int (variable-closure-index variable)) - (emit-array-store (variable-representation variable))) + (emit 'aaload) + (emit 'getfield "org/armedbear/lisp/ClosureBinding" "value" + "Lorg/armedbear/lisp/LispObject;")) (t ;;###FIXME: We might want to address the "temp-register" case too. (assert nil))))) @@ -4869,7 +4877,7 @@ (emit 'checkcast +lisp-ctf-class+) (aload (compiland-closure-register parent)) (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) + (list +lisp-object+ +closure-binding-array+) +lisp-object+))) (emit-move-to-variable (local-function-variable local-function))) @@ -5017,7 +5025,7 @@ ((compiland-closure-register *current-compiland*) (aload (compiland-closure-register *current-compiland*)) (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) + (list +lisp-object+ +closure-binding-array+) +lisp-object+) (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure (t @@ -5049,7 +5057,7 @@ (emit 'checkcast +lisp-ctf-class+) (aload (compiland-closure-register *current-compiland*)) (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) + (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) (emit-move-from-stack target)) ((inline-ok name) @@ -7886,19 +7894,20 @@ (setf *hairy-arglist-p* t) (return-from analyze-args (if *closure-variables* - (get-descriptor (list +lisp-object-array+ +lisp-object-array+) - +lisp-object+) + (get-descriptor (list +closure-binding-array+ + +lisp-object-array+) + +lisp-object+) (get-descriptor (list +lisp-object-array+) - +lisp-object+)))) + +lisp-object+)))) (cond (*closure-variables* (return-from analyze-args (cond ((<= arg-count call-registers-limit) - (get-descriptor (list* +lisp-object-array+ + (get-descriptor (list* +closure-binding-array+ (lisp-object-arg-types arg-count)) +lisp-object+)) (t (setf *using-arg-array* t) (setf (compiland-arity compiland) arg-count) - (get-descriptor (list +lisp-object-array+ +lisp-object-array+) ;; FIXME + (get-descriptor (list +closure-binding-array+ +lisp-object-array+) ;; FIXME +lisp-object+))))) (t (return-from analyze-args @@ -8105,7 +8114,7 @@ (emit-push-constant-int (length *closure-variables*)) (dformat t "p2-compiland ~S anewarray 1~%" (compiland-name compiland)) - (emit 'anewarray "org/armedbear/lisp/LispObject"))) + (emit 'anewarray "org/armedbear/lisp/ClosureBinding"))) (dolist (variable closure-args) (dformat t "moving variable ~S~%" (variable-name variable)) (cond ((variable-register variable) @@ -8114,6 +8123,10 @@ (emit 'dup) ; array (emit-push-constant-int (variable-closure-index variable)) (aload (variable-register variable)) + (emit 'new "org/armedbear/lisp/ClosureBinding") + (emit 'dup) + (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" + (list "Lorg/armedbear/lisp/LisObject;")) (emit 'aastore) (setf (variable-register variable) nil)) ((variable-index variable) @@ -8122,6 +8135,10 @@ (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) (emit 'aaload) + (emit 'new "org/armedbear/lisp/ClosureBinding") + (emit 'dup) + (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" + (list "Lorg/armedbear/lisp/LisObject;")) (emit 'aastore) (setf (variable-index variable) nil)))) From ehuelsmann at common-lisp.net Thu May 14 20:00:25 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 14 May 2009 16:00:25 -0400 Subject: [armedbear-cvs] r11862 - branches/closure-fixes/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 14 16:00:24 2009 New Revision: 11862 Log: Fix stack ordering problems introduced when creating closure bindings. Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 14 16:00:24 2009 @@ -3919,14 +3919,17 @@ (emit 'swap) (emit-invokevirtual +lisp-thread-class+ "bindSpecial" (list +lisp-symbol+ +lisp-object+) nil)) - ((variable-closure-index variable) - (emit 'new "org/armedbear/lisp/ClosureBinding") - (emit 'dup) + ((variable-closure-index variable) ;; stack: + (emit 'new "org/armedbear/lisp/ClosureBinding") ;; value c-b + (emit 'dup_x1) ;; c-b value c-b + (emit 'swap) ;; c-b c-b value (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" - (list +lisp-object+)) + (list +lisp-object+)) ;; c-b (aload (compiland-closure-register *current-compiland*)) - (emit 'swap) ; array value + ;; 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)) (t @@ -8122,23 +8125,23 @@ (compiland-closure-register compiland)))) (emit 'dup) ; array (emit-push-constant-int (variable-closure-index variable)) - (aload (variable-register variable)) (emit 'new "org/armedbear/lisp/ClosureBinding") (emit 'dup) + (aload (variable-register variable)) (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" - (list "Lorg/armedbear/lisp/LisObject;")) + (list +lisp-object+)) (emit 'aastore) (setf (variable-register variable) nil)) ((variable-index variable) (emit 'dup) ; array (emit-push-constant-int (variable-closure-index variable)) + (emit 'new "org/armedbear/lisp/ClosureBinding") + (emit 'dup) (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) (emit 'aaload) - (emit 'new "org/armedbear/lisp/ClosureBinding") - (emit 'dup) (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" - (list "Lorg/armedbear/lisp/LisObject;")) + (list +lisp-object+)) (emit 'aastore) (setf (variable-index variable) nil)))) From ehuelsmann at common-lisp.net Thu May 14 20:52:16 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 14 May 2009 16:52:16 -0400 Subject: [armedbear-cvs] r11863 - branches/closure-fixes/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 14 16:52:15 2009 New Revision: 11863 Log: Initialize the closure slots with a binding, so that we won't need to check for that condition when we want to set it later on. Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 14 16:52:15 2009 @@ -8110,40 +8110,45 @@ (and *closure-variables* (not *child-p*))) (dformat t "~S moving arguments to closure array~%" (compiland-name compiland)) - (cond (*child-p* - (aver (eql (compiland-closure-register compiland) 1)) - (aload (compiland-closure-register compiland))) - (t ;; if we're the ultimate parent: create the closure array - (emit-push-constant-int (length *closure-variables*)) - (dformat t "p2-compiland ~S anewarray 1~%" - (compiland-name compiland)) - (emit 'anewarray "org/armedbear/lisp/ClosureBinding"))) - (dolist (variable closure-args) - (dformat t "moving variable ~S~%" (variable-name variable)) - (cond ((variable-register variable) + (if *child-p* + (aload (compiland-closure-register compiland)) + (progn + ;; if we're the ultimate parent: create the closure array + (emit-push-constant-int (length *closure-variables*)) + (emit 'anewarray "org/armedbear/lisp/ClosureBinding"))) + (dotimes (i (length *closure-variables*)) + ;; Loop over all slots, setting their value + ;; unconditionally if we're the parent creating it (using null + ;; values if no real value is available) + ;; or selectively if we're a child binding certain slots. + (let ((variable (find i closure-args + :key #'variable-closure-index + :test #'eql))) + (when (or (not *child-p*) variable) + ;; we're the parent, or we have a variable to set. + (emit 'dup) ; array + (emit-push-constant-int i) + (emit 'new "org/armedbear/lisp/ClosureBinding") + (emit 'dup) + (cond + ((null variable) + (assert (not *child-p*)) + (emit 'aconst_null)) + ((variable-register variable) (assert (not (eql (variable-register variable) (compiland-closure-register compiland)))) - (emit 'dup) ; array - (emit-push-constant-int (variable-closure-index variable)) - (emit 'new "org/armedbear/lisp/ClosureBinding") - (emit 'dup) (aload (variable-register variable)) - (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" - (list +lisp-object+)) - (emit 'aastore) (setf (variable-register variable) nil)) ((variable-index variable) - (emit 'dup) ; array - (emit-push-constant-int (variable-closure-index variable)) - (emit 'new "org/armedbear/lisp/ClosureBinding") - (emit 'dup) (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) (emit 'aaload) - (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" - (list +lisp-object+)) - (emit 'aastore) - (setf (variable-index variable) nil)))) + (setf (variable-index variable) nil)) + (t + (assert (not "Can't happen!!")))) + (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" + (list +lisp-object+)) + (emit 'aastore)))) (aver (not (null (compiland-closure-register compiland)))) (cond (*child-p* From ehuelsmann at common-lisp.net Fri May 15 07:36:41 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 03:36:41 -0400 Subject: [armedbear-cvs] r11864 - branches/closure-fixes/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 03:36:38 2009 New Revision: 11864 Log: Duplicate closure arrays if the compiland defines bindings of itself: that allows storing a new binding without clobbering other closure arrays. Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 03:36:38 2009 @@ -206,6 +206,8 @@ (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") +(defconstant +closure-binding+ "Lorg/armedbear/lisp/ClosureBinding;") +(defconstant +closure-binding-class+ "org/armedbear/lisp/ClosureBinding") (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") (defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject") @@ -3010,6 +3012,24 @@ (aload register) (emit 'aastore)))) +(defun duplicate-closure-array (compiland) + (let* ((*register* *register*) + (register (allocate-register))) + (aload (compiland-closure-register compiland)) ;; src + (emit-push-constant-int 0) ;; srcPos + (emit-push-constant-int (length *closure-variables*)) + (emit 'anewarray "org/armedbear/lisp/ClosureBinding") ;; dest + (emit 'dup) + (astore register) ;; save dest value + (emit-push-constant-int 0) ;; destPos + (emit-push-constant-int (length *closure-variables*)) ;; length + (emit-invokestatic "java/lang/System" "arraycopy" + (list "Ljava/lang/Object;" "I" + "Ljava/lang/Object;" "I" "I") "V") + (aload register))) ;; reload dest value + + + (defknown compile-local-function-call (t t t) t) (defun compile-local-function-call (form target representation) "Compiles a call to a function marked as `*child-p*'; a local function. @@ -8044,6 +8064,8 @@ (args (cadr p1-result)) (closure-args (intersection *closure-variables* (compiland-arg-vars compiland))) + (local-closure-vars + (find compiland *closure-variables* :key #'variable-compiland)) (body (cddr p1-result)) (*using-arg-array* nil) (*hairy-arglist-p* nil) @@ -8105,17 +8127,20 @@ (dformat t "p2-compiland 2 closure register = ~S~%" (compiland-closure-register compiland))) + (when *closure-variables* + (cond + ((not *child-p*) + ;; if we're the ultimate parent: create the closure array + (emit-push-constant-int (length *closure-variables*)) + (emit 'anewarray "org/armedbear/lisp/ClosureBinding")) + (local-closure-vars + (duplicate-closure-array compiland)))) + ;; Move args from their original registers to the closure variables array (when (or closure-args (and *closure-variables* (not *child-p*))) (dformat t "~S moving arguments to closure array~%" (compiland-name compiland)) - (if *child-p* - (aload (compiland-closure-register compiland)) - (progn - ;; if we're the ultimate parent: create the closure array - (emit-push-constant-int (length *closure-variables*)) - (emit 'anewarray "org/armedbear/lisp/ClosureBinding"))) (dotimes (i (length *closure-variables*)) ;; Loop over all slots, setting their value ;; unconditionally if we're the parent creating it (using null @@ -8148,13 +8173,11 @@ (assert (not "Can't happen!!")))) (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" (list +lisp-object+)) - (emit 'aastore)))) + (emit 'aastore))))) + (when (or local-closure-vars (and *closure-variables* (not *child-p*))) (aver (not (null (compiland-closure-register compiland)))) - (cond (*child-p* - (emit 'pop)) - (t - (astore (compiland-closure-register compiland)))) + (astore (compiland-closure-register compiland)) (dformat t "~S done moving arguments to closure array~%" (compiland-name compiland))) From ehuelsmann at common-lisp.net Fri May 15 09:20:21 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 05:20:21 -0400 Subject: [armedbear-cvs] r11865 - branches/closure-fixes/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 05:20:17 2009 New Revision: 11865 Log: Create new closure arrays when creating new closures. This prevents the parent from clobbering closures which it already created, when changing its own closure array. Variable saving and restoring is no longer necessary: all the closure array copying does the same thing (better). Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 05:20:17 2009 @@ -2991,26 +2991,6 @@ (fix-boxing representation nil) (emit-move-from-stack target)) -(defun save-variables (variables) - (let ((saved-vars '())) - (dolist (variable variables) - (when (variable-closure-index variable) - (let ((register (allocate-register))) - (aload (compiland-closure-register *current-compiland*)) - (emit-push-constant-int (variable-closure-index variable)) - (emit 'aaload) - (astore register) - (push (cons variable register) saved-vars)))) - saved-vars)) - -(defun restore-variables (saved-vars) - (dolist (saved-var saved-vars) - (let ((variable (car saved-var)) - (register (cdr saved-var))) - (aload (compiland-closure-register *current-compiland*)) - (emit-push-constant-int (variable-closure-index variable)) - (aload register) - (emit 'aastore)))) (defun duplicate-closure-array (compiland) (let* ((*register* *register*) @@ -3025,7 +3005,7 @@ (emit-push-constant-int (length *closure-variables*)) ;; length (emit-invokestatic "java/lang/System" "arraycopy" (list "Ljava/lang/Object;" "I" - "Ljava/lang/Object;" "I" "I") "V") + "Ljava/lang/Object;" "I" "I") nil) (aload register))) ;; reload dest value @@ -3040,23 +3020,11 @@ (op (car form)) (args (cdr form)) (local-function (find-local-function op)) - (*register* *register*) - (saved-vars '()) - (label-START (gensym)) - (label-END (gensym)) - (label-EXIT (gensym))) + (*register* *register*)) (cond ((local-function-variable local-function) ;; LABELS (dformat t "compile-local-function-call LABELS case variable = ~S~%" (variable-name (local-function-variable local-function))) - (unless (null (compiland-parent compiland)) - (setf saved-vars - (save-variables (intersection - (compiland-arg-vars (local-function-compiland local-function)) - *visible-variables*)))) -;; (emit 'var-ref (local-function-variable local-function) 'stack) - (when saved-vars - (label label-START)) (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)) (t (dformat t "compile-local-function-call default case~%") @@ -3066,25 +3034,14 @@ (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* (emit 'checkcast +lisp-ctf-class+) - (aload (compiland-closure-register compiland)) + (duplicate-closure-array compiland) (emit-invokestatic +lisp-class+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) (process-args args) (emit-call-execute (length args)) (fix-boxing representation nil) - (emit-move-from-stack target representation) - (when saved-vars - (emit 'goto label-EXIT) - (label label-END) - (restore-variables saved-vars) - (emit 'athrow) - (label label-EXIT) - (restore-variables saved-vars) - (push (make-handler :from label-START - :to label-END - :code label-END - :catch-type 0) *handlers*))) + (emit-move-from-stack target representation)) t) @@ -4898,7 +4855,7 @@ (dformat t "(compiland-closure-register parent) = ~S~%" (compiland-closure-register parent)) (emit 'checkcast +lisp-ctf-class+) - (aload (compiland-closure-register parent)) + (duplicate-closure-array parent) (emit-invokestatic +lisp-class+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))) @@ -5046,7 +5003,7 @@ (delete-file pathname))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) - (aload (compiland-closure-register *current-compiland*)) + (duplicate-closure-array *current-compiland*) (emit-invokestatic +lisp-class+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+) @@ -5078,7 +5035,7 @@ (when (compiland-closure-register *current-compiland*) (emit 'checkcast +lisp-ctf-class+) - (aload (compiland-closure-register *current-compiland*)) + (duplicate-closure-array *current-compiland*) (emit-invokestatic +lisp-class+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) From ehuelsmann at common-lisp.net Fri May 15 09:30:13 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 05:30:13 -0400 Subject: [armedbear-cvs] r11866 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 05:30:10 2009 New Revision: 11866 Log: Finish closure fixes by merging the branch to the trunk. Added: trunk/abcl/src/org/armedbear/lisp/ClosureBinding.java - copied unchanged from r11865, /branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureBinding.java Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Fri May 15 05:30:10 2009 @@ -37,7 +37,7 @@ implements Cloneable { - public LispObject[] ctx; + public ClosureBinding[] ctx; public ClosureTemplateFunction(LispObject lambdaList) throws ConditionThrowable @@ -45,7 +45,7 @@ super(list(Symbol.LAMBDA, lambdaList), null); } - final public ClosureTemplateFunction setContext(LispObject[] context) + final public ClosureTemplateFunction setContext(ClosureBinding[] context) { ctx = context; return this; @@ -156,14 +156,14 @@ // "evaluate this template with these values" // Zero args. - public LispObject _execute(LispObject[] context) throws ConditionThrowable + public LispObject _execute(ClosureBinding[] context) throws ConditionThrowable { LispObject[] args = new LispObject[0]; return _execute(context, args); } // One arg. - public LispObject _execute(LispObject[] context, LispObject first) + public LispObject _execute(ClosureBinding[] context, LispObject first) throws ConditionThrowable { LispObject[] args = new LispObject[1]; @@ -172,7 +172,7 @@ } // Two args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second) throws ConditionThrowable { @@ -183,7 +183,7 @@ } // Three args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third) throws ConditionThrowable { @@ -195,7 +195,7 @@ } // Four args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable @@ -209,7 +209,7 @@ } // Five args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) throws ConditionThrowable @@ -224,7 +224,7 @@ } // Six args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) @@ -241,7 +241,7 @@ } // Seven args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh) @@ -259,7 +259,7 @@ } // Eight args. - public LispObject _execute(LispObject[] context, LispObject first, + public LispObject _execute(ClosureBinding[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh, @@ -279,7 +279,7 @@ } // Arg array. - public LispObject _execute(LispObject[] context, LispObject[] args) + public LispObject _execute(ClosureBinding[] context, LispObject[] args) throws ConditionThrowable { return notImplemented(); Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Fri May 15 05:30:10 2009 @@ -36,9 +36,9 @@ public class CompiledClosure extends Function { private final ClosureTemplateFunction ctf; - private final LispObject[] context; + private final ClosureBinding[] context; - public CompiledClosure(ClosureTemplateFunction ctf, LispObject[] context) + public CompiledClosure(ClosureTemplateFunction ctf, ClosureBinding[] context) { super(ctf.getLambdaName(), ctf.getLambdaList()); this.ctf = ctf; 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 May 15 05:30:10 2009 @@ -1186,7 +1186,7 @@ } public static final LispObject makeCompiledClosure(LispObject template, - LispObject[] context) + ClosureBinding[] context) throws ConditionThrowable { ClosureTemplateFunction ctf = ((ClosureTemplateFunction) template).dup(); 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 May 15 05:30:10 2009 @@ -205,6 +205,9 @@ (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") +(defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") +(defconstant +closure-binding+ "Lorg/armedbear/lisp/ClosureBinding;") +(defconstant +closure-binding-class+ "org/armedbear/lisp/ClosureBinding") (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") (defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject") @@ -2988,26 +2991,24 @@ (fix-boxing representation nil) (emit-move-from-stack target)) -(defun save-variables (variables) - (let ((saved-vars '())) - (dolist (variable variables) - (when (variable-closure-index variable) - (let ((register (allocate-register))) - (aload (compiland-closure-register *current-compiland*)) - (emit-push-constant-int (variable-closure-index variable)) - (emit 'aaload) - (astore register) - (push (cons variable register) saved-vars)))) - saved-vars)) - -(defun restore-variables (saved-vars) - (dolist (saved-var saved-vars) - (let ((variable (car saved-var)) - (register (cdr saved-var))) - (aload (compiland-closure-register *current-compiland*)) - (emit-push-constant-int (variable-closure-index variable)) - (aload register) - (emit 'aastore)))) + +(defun duplicate-closure-array (compiland) + (let* ((*register* *register*) + (register (allocate-register))) + (aload (compiland-closure-register compiland)) ;; src + (emit-push-constant-int 0) ;; srcPos + (emit-push-constant-int (length *closure-variables*)) + (emit 'anewarray "org/armedbear/lisp/ClosureBinding") ;; dest + (emit 'dup) + (astore register) ;; save dest value + (emit-push-constant-int 0) ;; destPos + (emit-push-constant-int (length *closure-variables*)) ;; length + (emit-invokestatic "java/lang/System" "arraycopy" + (list "Ljava/lang/Object;" "I" + "Ljava/lang/Object;" "I" "I") nil) + (aload register))) ;; reload dest value + + (defknown compile-local-function-call (t t t) t) (defun compile-local-function-call (form target representation) @@ -3019,23 +3020,11 @@ (op (car form)) (args (cdr form)) (local-function (find-local-function op)) - (*register* *register*) - (saved-vars '()) - (label-START (gensym)) - (label-END (gensym)) - (label-EXIT (gensym))) + (*register* *register*)) (cond ((local-function-variable local-function) ;; LABELS (dformat t "compile-local-function-call LABELS case variable = ~S~%" (variable-name (local-function-variable local-function))) - (unless (null (compiland-parent compiland)) - (setf saved-vars - (save-variables (intersection - (compiland-arg-vars (local-function-compiland local-function)) - *visible-variables*)))) -;; (emit 'var-ref (local-function-variable local-function) 'stack) - (when saved-vars - (label label-START)) (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)) (t (dformat t "compile-local-function-call default case~%") @@ -3045,25 +3034,14 @@ (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* (emit 'checkcast +lisp-ctf-class+) - (aload (compiland-closure-register compiland)) + (duplicate-closure-array compiland) (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) + (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) (process-args args) (emit-call-execute (length args)) (fix-boxing representation nil) - (emit-move-from-stack target representation) - (when saved-vars - (emit 'goto label-EXIT) - (label label-END) - (restore-variables saved-vars) - (emit 'athrow) - (label label-EXIT) - (restore-variables saved-vars) - (push (make-handler :from label-START - :to label-END - :code label-END - :catch-type 0) *handlers*))) + (emit-move-from-stack target representation)) t) @@ -3918,10 +3896,17 @@ (emit 'swap) (emit-invokevirtual +lisp-thread-class+ "bindSpecial" (list +lisp-symbol+ +lisp-object+) nil)) - ((variable-closure-index variable) + ((variable-closure-index variable) ;; stack: + (emit 'new "org/armedbear/lisp/ClosureBinding") ;; value c-b + (emit 'dup_x1) ;; c-b value c-b + (emit 'swap) ;; c-b c-b value + (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" + (list +lisp-object+)) ;; c-b (aload (compiland-closure-register *current-compiland*)) - (emit 'swap) ; array value + ;; 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)) (t @@ -4195,16 +4180,17 @@ (emit-array-store (variable-representation variable))) ((variable-closure-index variable) (aload (compiland-closure-register *current-compiland*)) - (emit-swap representation nil) (emit-push-constant-int (variable-closure-index variable)) - (emit-swap representation :int) - (emit-array-store (variable-representation variable))) + (emit 'aaload) + (emit-swap representation nil) + (emit 'putfield "org/armedbear/lisp/ClosureBinding" "value" + "Lorg/armedbear/lisp/LispObject;")) (t ;;###FIXME: We might want to address the "temp-register" case too. (assert nil)))))) (defun emit-push-variable (variable) - (flet ((emit-array-store (representation) + (flet ((emit-array-load (representation) (emit (ecase representation ((:int :boolean :char) 'iaload) @@ -4224,11 +4210,13 @@ ((variable-index variable) (aload (compiland-argument-register *current-compiland*)) (emit-push-constant-int (variable-index variable)) - (emit-array-store (variable-representation variable))) + (emit-array-load (variable-representation variable))) ((variable-closure-index variable) (aload (compiland-closure-register *current-compiland*)) (emit-push-constant-int (variable-closure-index variable)) - (emit-array-store (variable-representation variable))) + (emit 'aaload) + (emit 'getfield "org/armedbear/lisp/ClosureBinding" "value" + "Lorg/armedbear/lisp/LispObject;")) (t ;;###FIXME: We might want to address the "temp-register" case too. (assert nil))))) @@ -4867,9 +4855,9 @@ (dformat t "(compiland-closure-register parent) = ~S~%" (compiland-closure-register parent)) (emit 'checkcast +lisp-ctf-class+) - (aload (compiland-closure-register parent)) + (duplicate-closure-array parent) (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) + (list +lisp-object+ +closure-binding-array+) +lisp-object+))) (emit-move-to-variable (local-function-variable local-function))) @@ -5015,9 +5003,9 @@ (delete-file pathname))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) - (aload (compiland-closure-register *current-compiland*)) + (duplicate-closure-array *current-compiland*) (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) + (list +lisp-object+ +closure-binding-array+) +lisp-object+) (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure (t @@ -5047,9 +5035,9 @@ (when (compiland-closure-register *current-compiland*) (emit 'checkcast +lisp-ctf-class+) - (aload (compiland-closure-register *current-compiland*)) + (duplicate-closure-array *current-compiland*) (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) + (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) (emit-move-from-stack target)) ((inline-ok name) @@ -7886,19 +7874,20 @@ (setf *hairy-arglist-p* t) (return-from analyze-args (if *closure-variables* - (get-descriptor (list +lisp-object-array+ +lisp-object-array+) - +lisp-object+) + (get-descriptor (list +closure-binding-array+ + +lisp-object-array+) + +lisp-object+) (get-descriptor (list +lisp-object-array+) - +lisp-object+)))) + +lisp-object+)))) (cond (*closure-variables* (return-from analyze-args (cond ((<= arg-count call-registers-limit) - (get-descriptor (list* +lisp-object-array+ + (get-descriptor (list* +closure-binding-array+ (lisp-object-arg-types arg-count)) +lisp-object+)) (t (setf *using-arg-array* t) (setf (compiland-arity compiland) arg-count) - (get-descriptor (list +lisp-object-array+ +lisp-object-array+) ;; FIXME + (get-descriptor (list +closure-binding-array+ +lisp-object-array+) ;; FIXME +lisp-object+))))) (t (return-from analyze-args @@ -8032,6 +8021,8 @@ (args (cadr p1-result)) (closure-args (intersection *closure-variables* (compiland-arg-vars compiland))) + (local-closure-vars + (find compiland *closure-variables* :key #'variable-compiland)) (body (cddr p1-result)) (*using-arg-array* nil) (*hairy-arglist-p* nil) @@ -8093,43 +8084,57 @@ (dformat t "p2-compiland 2 closure register = ~S~%" (compiland-closure-register compiland))) + (when *closure-variables* + (cond + ((not *child-p*) + ;; if we're the ultimate parent: create the closure array + (emit-push-constant-int (length *closure-variables*)) + (emit 'anewarray "org/armedbear/lisp/ClosureBinding")) + (local-closure-vars + (duplicate-closure-array compiland)))) + ;; Move args from their original registers to the closure variables array (when (or closure-args (and *closure-variables* (not *child-p*))) (dformat t "~S moving arguments to closure array~%" (compiland-name compiland)) - (cond (*child-p* - (aver (eql (compiland-closure-register compiland) 1)) - (aload (compiland-closure-register compiland))) - (t ;; if we're the ultimate parent: create the closure array - (emit-push-constant-int (length *closure-variables*)) - (dformat t "p2-compiland ~S anewarray 1~%" - (compiland-name compiland)) - (emit 'anewarray "org/armedbear/lisp/LispObject"))) - (dolist (variable closure-args) - (dformat t "moving variable ~S~%" (variable-name variable)) - (cond ((variable-register variable) + (dotimes (i (length *closure-variables*)) + ;; Loop over all slots, setting their value + ;; unconditionally if we're the parent creating it (using null + ;; values if no real value is available) + ;; or selectively if we're a child binding certain slots. + (let ((variable (find i closure-args + :key #'variable-closure-index + :test #'eql))) + (when (or (not *child-p*) variable) + ;; we're the parent, or we have a variable to set. + (emit 'dup) ; array + (emit-push-constant-int i) + (emit 'new "org/armedbear/lisp/ClosureBinding") + (emit 'dup) + (cond + ((null variable) + (assert (not *child-p*)) + (emit 'aconst_null)) + ((variable-register variable) (assert (not (eql (variable-register variable) (compiland-closure-register compiland)))) - (emit 'dup) ; array - (emit-push-constant-int (variable-closure-index variable)) (aload (variable-register variable)) - (emit 'aastore) (setf (variable-register variable) nil)) ((variable-index variable) - (emit 'dup) ; array - (emit-push-constant-int (variable-closure-index variable)) (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) (emit 'aaload) - (emit 'aastore) - (setf (variable-index variable) nil)))) + (setf (variable-index variable) nil)) + (t + (assert (not "Can't happen!!")))) + (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" + (list +lisp-object+)) + (emit 'aastore))))) + (when (or local-closure-vars (and *closure-variables* (not *child-p*))) (aver (not (null (compiland-closure-register compiland)))) - (cond (*child-p* - (emit 'pop)) - (t - (astore (compiland-closure-register compiland)))) + (astore (compiland-closure-register compiland)) (dformat t "~S done moving arguments to closure array~%" (compiland-name compiland))) From ehuelsmann at common-lisp.net Fri May 15 09:35:05 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 05:35:05 -0400 Subject: [armedbear-cvs] r11867 - branches/closure-fixes Message-ID: Author: ehuelsmann Date: Fri May 15 05:35:04 2009 New Revision: 11867 Log: Delete merged branch. Removed: branches/closure-fixes/ From ehuelsmann at common-lisp.net Fri May 15 10:20:11 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 06:20:11 -0400 Subject: [armedbear-cvs] r11868 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 06:20:09 2009 New Revision: 11868 Log: Replace string literals with constants. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 06:20:09 2009 @@ -199,6 +199,7 @@ n))) (defconstant +java-string+ "Ljava/lang/String;") +(defconstant +java-object+ "Ljava/lang/Object;") (defconstant +lisp-class+ "org/armedbear/lisp/Lisp") (defconstant +lisp-nil-class+ "org/armedbear/lisp/Nil") (defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass") @@ -206,7 +207,6 @@ (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") -(defconstant +closure-binding+ "Lorg/armedbear/lisp/ClosureBinding;") (defconstant +closure-binding-class+ "org/armedbear/lisp/ClosureBinding") (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") @@ -2998,14 +2998,14 @@ (aload (compiland-closure-register compiland)) ;; src (emit-push-constant-int 0) ;; srcPos (emit-push-constant-int (length *closure-variables*)) - (emit 'anewarray "org/armedbear/lisp/ClosureBinding") ;; dest + (emit 'anewarray +closure-binding-class+) ;; dest (emit 'dup) (astore register) ;; save dest value (emit-push-constant-int 0) ;; destPos (emit-push-constant-int (length *closure-variables*)) ;; length (emit-invokestatic "java/lang/System" "arraycopy" - (list "Ljava/lang/Object;" "I" - "Ljava/lang/Object;" "I" "I") nil) + (list +java-object+ "I" + +java-object+ "I" "I") nil) (aload register))) ;; reload dest value @@ -3897,11 +3897,11 @@ (emit-invokevirtual +lisp-thread-class+ "bindSpecial" (list +lisp-symbol+ +lisp-object+) nil)) ((variable-closure-index variable) ;; stack: - (emit 'new "org/armedbear/lisp/ClosureBinding") ;; value c-b - (emit 'dup_x1) ;; c-b value c-b - (emit 'swap) ;; c-b c-b value - (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" - (list +lisp-object+)) ;; c-b + (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 @@ -4183,8 +4183,7 @@ (emit-push-constant-int (variable-closure-index variable)) (emit 'aaload) (emit-swap representation nil) - (emit 'putfield "org/armedbear/lisp/ClosureBinding" "value" - "Lorg/armedbear/lisp/LispObject;")) + (emit 'putfield +closure-binding-class+ "value" +lisp-object+)) (t ;;###FIXME: We might want to address the "temp-register" case too. (assert nil)))))) @@ -4215,8 +4214,7 @@ (aload (compiland-closure-register *current-compiland*)) (emit-push-constant-int (variable-closure-index variable)) (emit 'aaload) - (emit 'getfield "org/armedbear/lisp/ClosureBinding" "value" - "Lorg/armedbear/lisp/LispObject;")) + (emit 'getfield +closure-binding-class+ "value" +lisp-object+)) (t ;;###FIXME: We might want to address the "temp-register" case too. (assert nil))))) @@ -8089,7 +8087,7 @@ ((not *child-p*) ;; if we're the ultimate parent: create the closure array (emit-push-constant-int (length *closure-variables*)) - (emit 'anewarray "org/armedbear/lisp/ClosureBinding")) + (emit 'anewarray +closure-binding-class+)) (local-closure-vars (duplicate-closure-array compiland)))) @@ -8110,7 +8108,7 @@ ;; we're the parent, or we have a variable to set. (emit 'dup) ; array (emit-push-constant-int i) - (emit 'new "org/armedbear/lisp/ClosureBinding") + (emit 'new +closure-binding-class+) (emit 'dup) (cond ((null variable) @@ -8128,7 +8126,7 @@ (setf (variable-index variable) nil)) (t (assert (not "Can't happen!!")))) - (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding" + (emit-invokespecial-init +closure-binding-class+ (list +lisp-object+)) (emit 'aastore))))) From ehuelsmann at common-lisp.net Fri May 15 11:58:18 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 07:58:18 -0400 Subject: [armedbear-cvs] r11869 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 07:58:14 2009 New Revision: 11869 Log: Remove unused variable-info structure slot (RESERVED-REGISTER). 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 Fri May 15 07:58:14 2009 @@ -257,7 +257,6 @@ closure-index ; index number for a variable in the closure context array ;; a variable can be either special-p *or* have a register *or* ;; have an index *or a closure-index - reserved-register (reads 0 :type fixnum) (writes 0 :type fixnum) references From ehuelsmann at common-lisp.net Fri May 15 17:19:39 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 13:19:39 -0400 Subject: [armedbear-cvs] r11870 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 13:19:34 2009 New Revision: 11870 Log: Remove the TEMP-REGISTER slot from the VARIABLE-INFO structure: it's used only locally. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 13:19:34 2009 @@ -4227,7 +4227,8 @@ (zerop (variable-reads variable))) (aver (null (variable-register variable))) (setf (variable-register variable) t))) - (let ((must-clear-values nil)) + (let (must-clear-values + temporary-storage) (declare (type boolean must-clear-values)) ;; Evaluate each initform. If the variable being bound is special, allocate ;; a temporary register for the result; LET bindings must be done in @@ -4258,9 +4259,12 @@ ;; Now allocate the register. (allocate-variable-register variable)) (cond ((variable-special-p variable) - (emit-move-from-stack - (setf (variable-temp-register variable) - (allocate-register)))) + (let ((temp-register (allocate-register))) + ;; FIXME: this permanently allocates a register + ;; which has only a single local use + (push (cons temp-register variable) + temporary-storage) + (emit-move-from-stack temp-register))) ((variable-representation variable) (emit-move-to-variable variable)) (t @@ -4269,11 +4273,9 @@ (emit-clear-values)) ;; Now that all the initforms have been evaluated, move the results from ;; the temporary registers (if any) to their proper destinations. - (dolist (variable (block-vars block)) - (when (variable-temp-register variable) - (aver (variable-special-p variable)) - (aload (variable-temp-register variable)) - (compile-binding variable)))) + (dolist (temp temporary-storage) + (aload (car temp)) + (compile-binding (cdr temp)))) ;; Now make the variables visible. (dolist (variable (block-vars block)) (push variable *visible-variables*)) 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 May 15 13:19:34 2009 @@ -245,7 +245,6 @@ (:predicate variable-p)) name initform - temp-register (declared-type :none) (derived-type :none) ignore-p From ehuelsmann at common-lisp.net Fri May 15 19:09:50 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 15:09:50 -0400 Subject: [armedbear-cvs] r11871 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 15:09:48 2009 New Revision: 11871 Log: Indenting < 80 columns. 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 Fri May 15 15:09:48 2009 @@ -350,7 +350,9 @@ ;; 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 node) (:constructor make-block-node (name))) +(defstruct (block-node (:conc-name block-) + (:include node) + (:constructor make-block-node (name))) (exit (gensym)) target catch-tag From ehuelsmann at common-lisp.net Fri May 15 19:16:28 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 15:16:28 -0400 Subject: [armedbear-cvs] r11872 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 15:16:27 2009 New Revision: 11872 Log: The TEMP-REGISTER slot has been removed, these FIXMEs don't apply anymore. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 15:16:27 2009 @@ -4185,7 +4185,6 @@ (emit-swap representation nil) (emit 'putfield +closure-binding-class+ "value" +lisp-object+)) (t - ;;###FIXME: We might want to address the "temp-register" case too. (assert nil)))))) (defun emit-push-variable (variable) @@ -4215,7 +4214,7 @@ (emit-push-constant-int (variable-closure-index variable)) (emit 'aaload) (emit 'getfield +closure-binding-class+ "value" +lisp-object+)) - (t ;;###FIXME: We might want to address the "temp-register" case too. + (t (assert nil))))) From ehuelsmann at common-lisp.net Fri May 15 19:32:05 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 15:32:05 -0400 Subject: [armedbear-cvs] r11873 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 15:32:01 2009 New Revision: 11873 Log: Don't use local function variables for FLET, not even in case of closures (reduces complexity in the compiler). Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri May 15 15:32:01 2009 @@ -591,7 +591,7 @@ (with-local-functions-for-flet/labels form local-functions lambda-list name body ((let ((local-function (make-local-function :name name - :compiland compiland))) + :compiland compiland))) (multiple-value-bind (body decls) (parse-body body) (let* ((block-name (fdefinition-block-name name)) (lambda-expression @@ -604,10 +604,6 @@ (setf (local-function-inline-expansion local-function) (generate-inline-expansion block-name lambda-list body)) (p1-compiland compiland))) - (when *closure-variables* - (let ((variable (make-variable :name (gensym)))) - (setf (local-function-variable local-function) variable) - (push variable *all-variables*))) (push local-function local-functions))) ((with-saved-compiler-policy (process-optimization-declarations (cddr 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 Fri May 15 15:32:01 2009 @@ -4846,7 +4846,7 @@ (compile-and-write-to-file class-file compiland)) -(defun emit-make-compiled-closure-for-flet/labels +(defun emit-make-compiled-closure-for-flet/labels (local-function compiland declaration) (emit 'getstatic *this-class* declaration +lisp-object+) (let ((parent (compiland-parent compiland))) @@ -4872,7 +4872,7 @@ (let ((*load-truename* (pathname pathname))) (unless (ignore-errors (load-compiled-function pathname)) (error "Unable to load ~S." pathname)))) - + (defknown p2-flet-process-compiland (t) t) (defun p2-flet-process-compiland (local-function) (let* ((compiland (local-function-compiland local-function)) @@ -4883,22 +4883,14 @@ :lambda-list lambda-list))) (set-compiland-and-write-class-file class-file compiland) (verify-class-file-loadable pathname) - (setf (local-function-class-file local-function) class-file)) - (when (local-function-variable local-function) - (let ((g (declare-local-function local-function))) - (emit-make-compiled-closure-for-flet/labels - local-function compiland g)))) + (setf (local-function-class-file local-function) class-file))) (t - (with-temp-class-file + (with-temp-class-file pathname class-file lambda-list (set-compiland-and-write-class-file class-file compiland) (setf (local-function-class-file local-function) class-file) (setf (local-function-function local-function) - (load-compiled-function pathname)) - (when (local-function-variable local-function) - (let ((g (declare-object (load-compiled-function pathname)))) - (emit-make-compiled-closure-for-flet/labels - local-function compiland g)))))))) + (load-compiled-function pathname))))))) (defknown p2-labels-process-compiland (t) t) (defun p2-labels-process-compiland (local-function) @@ -4912,7 +4904,7 @@ (verify-class-file-loadable pathname) (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-flet/labels local-function compiland g)))) (t (with-temp-class-file @@ -4920,7 +4912,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-flet/labels local-function compiland g))))))) (defknown p2-flet (t t t) t) @@ -4932,12 +4924,6 @@ (local-functions (cadr form)) (body (cddr form))) (dolist (local-function local-functions) - (let ((variable (local-function-variable local-function))) - (when variable - (aver (null (variable-register variable))) - (unless (variable-closure-index variable) - (setf (variable-register variable) (allocate-register)))))) - (dolist (local-function local-functions) (p2-flet-process-compiland local-function)) (dolist (local-function local-functions) (push local-function *local-functions*) From ehuelsmann at common-lisp.net Fri May 15 20:18:11 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 16:18:11 -0400 Subject: [armedbear-cvs] r11874 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 16:18:09 2009 New Revision: 11874 Log: P2-FLET and P2-LABELS: Use COMPILE-PROGN-BODY instead of reinventing the wheel. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 16:18:09 2009 @@ -4917,8 +4917,6 @@ (defknown p2-flet (t t t) t) (defun p2-flet (form target representation) - ;; FIXME What if we're called with a non-NIL representation? - (declare (ignore representation)) (let ((*local-functions* *local-functions*) (*visible-variables* *visible-variables*) (local-functions (cadr form)) @@ -4931,11 +4929,8 @@ (when variable (push variable *visible-variables*)))) (dolist (special (process-special-declarations body)) - (push (make-variable :name special :special-p t) - *visible-variables*)) - (do ((forms body (cdr forms))) - ((null forms)) - (compile-form (car forms) (if (cdr forms) nil target) nil)))) + (push (make-variable :name special :special-p t) *visible-variables*)) + (compile-progn-body body target representation))) (defknown p2-labels (t t t) t) (defun p2-labels (form target representation) @@ -4954,13 +4949,8 @@ (dolist (local-function local-functions) (p2-labels-process-compiland local-function)) (dolist (special (process-special-declarations body)) - (push (make-variable :name special :special-p t) - *visible-variables*)) - (do ((forms body (cdr forms))) - ((null forms)) - (compile-form (car forms) (if (cdr forms) nil 'stack) nil)) - (fix-boxing representation nil) - (emit-move-from-stack target representation))) + (push (make-variable :name special :special-p t) *visible-variables*)) + (compile-progn-body body target representation))) (defun p2-lambda (compiland target) (let* ((lambda-list (cadr (compiland-lambda-expression compiland)))) From ehuelsmann at common-lisp.net Fri May 15 20:20:43 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 16:20:43 -0400 Subject: [armedbear-cvs] r11875 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 16:20:41 2009 New Revision: 11875 Log: FLET doesn't do variables anymore, remove remnants in P2-FLET. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 16:20:41 2009 @@ -4924,10 +4924,7 @@ (dolist (local-function local-functions) (p2-flet-process-compiland local-function)) (dolist (local-function local-functions) - (push local-function *local-functions*) - (let ((variable (local-function-variable local-function))) - (when variable - (push variable *visible-variables*)))) + (push local-function *local-functions*)) (dolist (special (process-special-declarations body)) (push (make-variable :name special :special-p t) *visible-variables*)) (compile-progn-body body target representation))) From ehuelsmann at common-lisp.net Fri May 15 20:43:33 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 16:43:33 -0400 Subject: [armedbear-cvs] r11876 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 16:43:31 2009 New Revision: 11876 Log: Reindent < 80 columns. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 16:43:31 2009 @@ -4959,7 +4959,8 @@ (let ((class-file (compiland-class-file compiland))) (compile-and-write-to-file class-file compiland) (emit 'getstatic *this-class* - (declare-local-function (make-local-function :class-file class-file)) + (declare-local-function (make-local-function :class-file + class-file)) +lisp-object+))) (t (let ((pathname (funcall *pathnames-generator*))) @@ -4968,18 +4969,20 @@ :lambda-list lambda-list)) (unwind-protect (progn - (compile-and-write-to-file (compiland-class-file compiland) compiland) + (compile-and-write-to-file (compiland-class-file compiland) + compiland) (emit 'getstatic *this-class* (declare-object (load-compiled-function pathname)) +lisp-object+)) (delete-file pathname))))) - (cond ((null *closure-variables*)) ; Nothing to do. + (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) (duplicate-closure-array *current-compiland*) (emit-invokestatic +lisp-class+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+) - (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure + (emit 'checkcast +lisp-compiled-closure-class+)) + ; Stack: compiled-closure (t (aver nil))) ;; Shouldn't happen. (emit-move-from-stack target))) @@ -4990,85 +4993,97 @@ (declare (ignore representation)) (let ((name (second form)) local-function) - (cond ((symbolp name) - (dformat t "p2-function case 1~%") - (cond ((setf local-function (find-local-function name)) - (dformat t "p2-function 1~%") - (cond ((local-function-variable local-function) - (dformat t "p2-function 2 emitting var-ref~%") -;; (emit 'var-ref (local-function-variable local-function) 'stack) - (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil) - ) - (t - (let ((g (if *file-compilation* - (declare-local-function local-function) - (declare-object (local-function-function local-function))))) - (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function - - (when (compiland-closure-register *current-compiland*) - (emit 'checkcast +lisp-ctf-class+) - (duplicate-closure-array *current-compiland*) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+))))) - (emit-move-from-stack target)) - ((inline-ok name) - (emit 'getstatic *this-class* - (declare-function name) +lisp-object+) - (emit-move-from-stack target)) - (t - (multiple-value-bind - (name class) - (lookup-or-declare-symbol name) - (emit 'getstatic class name +lisp-symbol+)) - (emit-invokevirtual +lisp-object-class+ - "getSymbolFunctionOrDie" - nil +lisp-object+) - (emit-move-from-stack target)))) - ((and (consp name) (eq (%car name) 'SETF)) - (dformat t "p2-function case 2~%") - ; FIXME Need to check for NOTINLINE declaration! - (cond ((setf local-function (find-local-function name)) - (dformat t "p2-function 1~%") - (when (eq (local-function-compiland local-function) *current-compiland*) - (aload 0) ; this - (emit-move-from-stack target) - (return-from p2-function)) - (cond ((local-function-variable local-function) - (dformat t "p2-function 2~%") -;; (emit 'var-ref (local-function-variable local-function) 'stack) - (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil) - ) - (t - (let ((g (if *file-compilation* - (declare-local-function local-function) - (declare-object (local-function-function local-function))))) - (emit 'getstatic *this-class* - g +lisp-object+))))) ; Stack: template-function - ((member name *functions-defined-in-current-file* :test #'equal) - (emit 'getstatic *this-class* - (declare-setf-function name) +lisp-object+) - (emit-move-from-stack target)) - ((and (null *file-compilation*) - (fboundp name) - (fdefinition name)) - (emit 'getstatic *this-class* - (declare-object (fdefinition name)) +lisp-object+) - (emit-move-from-stack target)) - (t - (multiple-value-bind - (name class) - (lookup-or-declare-symbol (cadr name)) - (emit 'getstatic class name +lisp-symbol+)) - (emit-invokevirtual +lisp-symbol-class+ - "getSymbolSetfFunctionOrDie" - nil +lisp-object+) - (emit-move-from-stack target)))) - ((compiland-p name) - (dformat t "p2-function case 3~%") - (p2-lambda name target)) - (t - (compiler-unsupported "p2-function: unsupported case: ~S" form))))) + (cond + ((symbolp name) + (dformat t "p2-function case 1~%") + (cond + ((setf local-function (find-local-function name)) + (dformat t "p2-function 1~%") + (cond + ((local-function-variable local-function) + (dformat t "p2-function 2 emitting var-ref~%") +;;; (emit 'var-ref (local-function-variable local-function) 'stack) + (compile-var-ref (make-var-ref + (local-function-variable local-function)) + 'stack nil) + ) + (t + (let ((g (if *file-compilation* + (declare-local-function local-function) + (declare-object + (local-function-function local-function))))) + (emit 'getstatic *this-class* g +lisp-object+) + ; Stack: template-function + + (when (compiland-closure-register *current-compiland*) + (emit 'checkcast +lisp-ctf-class+) + (duplicate-closure-array *current-compiland*) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +closure-binding-array+) + +lisp-object+))))) + (emit-move-from-stack target)) + ((inline-ok name) + (emit 'getstatic *this-class* + (declare-function name) +lisp-object+) + (emit-move-from-stack target)) + (t + (multiple-value-bind + (name class) + (lookup-or-declare-symbol name) + (emit 'getstatic class name +lisp-symbol+)) + (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie" + nil +lisp-object+) + (emit-move-from-stack target)))) + ((and (consp name) (eq (%car name) 'SETF)) + (dformat t "p2-function case 2~%") + ;; FIXME Need to check for NOTINLINE declaration! + (cond + ((setf local-function (find-local-function name)) + (dformat t "p2-function 1~%") + (when (eq (local-function-compiland local-function) + *current-compiland*) + (aload 0) ; this + (emit-move-from-stack target) + (return-from p2-function)) + (cond + ((local-function-variable local-function) + (dformat t "p2-function 2~%") +;; (emit 'var-ref (local-function-variable local-function) 'stack) + (compile-var-ref (make-var-ref + (local-function-variable local-function)) + 'stack nil) + ) + (t + (let ((g (if *file-compilation* + (declare-local-function local-function) + (declare-object + (local-function-function local-function))))) + (emit 'getstatic *this-class* + g +lisp-object+))))) ; Stack: template-function + ((member name *functions-defined-in-current-file* :test #'equal) + (emit 'getstatic *this-class* + (declare-setf-function name) +lisp-object+) + (emit-move-from-stack target)) + ((and (null *file-compilation*) + (fboundp name) + (fdefinition name)) + (emit 'getstatic *this-class* + (declare-object (fdefinition name)) +lisp-object+) + (emit-move-from-stack target)) + (t + (multiple-value-bind + (name class) + (lookup-or-declare-symbol (cadr name)) + (emit 'getstatic class name +lisp-symbol+)) + (emit-invokevirtual +lisp-symbol-class+ + "getSymbolSetfFunctionOrDie" + nil +lisp-object+) + (emit-move-from-stack target)))) + ((compiland-p name) + (dformat t "p2-function case 3~%") + (p2-lambda name target)) + (t + (compiler-unsupported "p2-function: unsupported case: ~S" form))))) (defknown p2-ash (t t t) t) (define-inlined-function p2-ash (form target representation) From ehuelsmann at common-lisp.net Fri May 15 20:45:32 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 May 2009 16:45:32 -0400 Subject: [armedbear-cvs] r11877 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 15 16:45:31 2009 New Revision: 11877 Log: Remove obsolete commented out code, more reindenting < 80 columns. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 16:45:31 2009 @@ -3025,13 +3025,17 @@ ;; LABELS (dformat t "compile-local-function-call LABELS case variable = ~S~%" (variable-name (local-function-variable local-function))) - (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)) + (compile-var-ref (make-var-ref + (local-function-variable local-function)) + 'stack nil)) (t (dformat t "compile-local-function-call default case~%") (let* ((g (if *file-compilation* (declare-local-function local-function) - (declare-object (local-function-function local-function))))) - (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function + (declare-object + (local-function-function local-function))))) + (emit 'getstatic *this-class* g +lisp-object+) + ; Stack: template-function (when *closure-variables* (emit 'checkcast +lisp-ctf-class+) (duplicate-closure-array compiland) @@ -5002,11 +5006,9 @@ (cond ((local-function-variable local-function) (dformat t "p2-function 2 emitting var-ref~%") -;;; (emit 'var-ref (local-function-variable local-function) 'stack) (compile-var-ref (make-var-ref (local-function-variable local-function)) - 'stack nil) - ) + 'stack nil)) (t (let ((g (if *file-compilation* (declare-local-function local-function) @@ -5048,11 +5050,9 @@ (cond ((local-function-variable local-function) (dformat t "p2-function 2~%") -;; (emit 'var-ref (local-function-variable local-function) 'stack) (compile-var-ref (make-var-ref (local-function-variable local-function)) - 'stack nil) - ) + 'stack nil)) (t (let ((g (if *file-compilation* (declare-local-function local-function) From ehuelsmann at common-lisp.net Sat May 16 07:26:06 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 03:26:06 -0400 Subject: [armedbear-cvs] r11878 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 16 03:26:03 2009 New Revision: 11878 Log: Add structure slot documentation. 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 Sat May 16 03:26:03 2009 @@ -153,14 +153,15 @@ (defstruct compiland name - (kind :external) ; :INTERNAL or :EXTERNAL + (kind :external) ; :INTERNAL or :EXTERNAL lambda-expression - arg-vars - free-specials - arity ; NIL if the number of args can vary. - p1-result - parent - (children 0 :type fixnum) ; Number of local functions defined with FLET or LABELS. + arg-vars ; variables for lambda arguments + free-specials ; + arity ; number of args, or NIL if the number of args can vary. + 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 argument-register closure-register environment-register @@ -327,9 +328,11 @@ name compiland inline-expansion - function + function ;; the function loaded through load-compiled-function class-file - variable) + variable ;; the variable which contains the loaded compiled function + ;; or compiled closure + ) (defvar *local-functions* ()) From ehuelsmann at common-lisp.net Sat May 16 07:26:32 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 03:26:32 -0400 Subject: [armedbear-cvs] r11879 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 16 03:26:31 2009 New Revision: 11879 Log: Reindenting for width < 80. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat May 16 03:26:31 2009 @@ -46,11 +46,14 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun generate-inline-expansion (block-name lambda-list body) - (cond ((intersection lambda-list '(&optional &rest &key &allow-other-keys &aux) :test 'eq) + (cond ((intersection lambda-list + '(&optional &rest &key &allow-other-keys &aux) + :test #'eq) nil) (t (setf body (copy-tree body)) - (list 'LAMBDA lambda-list (precompile-form (list* 'BLOCK block-name body) t))))) + (list 'LAMBDA lambda-list + (precompile-form (list* 'BLOCK block-name body) t))))) ) ; EVAL-WHEN ;;; Pass 1. @@ -76,11 +79,13 @@ (let ((variable (find-variable name variables))) (cond ((and variable ;; see comment below (and DO-ALL-SYMBOLS.11) - (eq (variable-compiland variable) *current-compiland*)) + (eq (variable-compiland variable) + *current-compiland*)) (setf (variable-special-p variable) t)) (t (dformat t "adding free special ~S~%" name) - (push (make-variable :name name :special-p t) free-specials)))))) + (push (make-variable :name name :special-p t) + free-specials)))))) (TYPE (dolist (name (cddr decl)) (let ((variable (find-variable name variables))) @@ -89,7 +94,8 @@ ;; a variable defined in its parent. For an example, ;; see CREATE-GREEDY-NO-ZERO-MATCHER in cl-ppcre. ;; FIXME suboptimal, since we ignore the declaration - (eq (variable-compiland variable) *current-compiland*)) + (eq (variable-compiland variable) + *current-compiland*)) (setf (variable-declared-type variable) (make-compiler-type (cadr decl))))))) (t @@ -158,7 +164,8 @@ ,varspec)) (let* ((,name (%car ,varspec)) (,initform (p1 (%cadr ,varspec))) - (,var (make-variable :name (check-name ,name) :initform ,initform))) + (,var (make-variable :name (check-name ,name) + :initform ,initform))) (push ,var ,variables-var) , at body1)) (t @@ -263,7 +270,8 @@ (process-declarations-for-vars body vars)) (setf (block-vars block) (nreverse vars))) (setf body (p1-body body)) - (setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body)) + (setf (block-form block) + (list* 'MULTIPLE-VALUE-BIND varlist values-form body)) block)) (defun p1-block (form) @@ -690,7 +698,8 @@ (dformat t "p1-function local function ~S~%" (cadr form)) (let ((variable (local-function-variable local-function))) (when variable - (dformat t "p1-function ~S used non-locally~%" (variable-name variable)) + (dformat t "p1-function ~S used non-locally~%" + (variable-name variable)) (setf (variable-used-non-locally-p variable) t))) form) (t @@ -848,7 +857,9 @@ (push (list sym arg) lets)) (t (push (list 'VALUES-LIST sym) syms) - (push (list sym (list 'MULTIPLE-VALUE-LIST arg)) lets)))))) + (push (list sym + (list 'MULTIPLE-VALUE-LIST arg)) + lets)))))) (list 'LET* (nreverse lets) (list* 'THROW (nreverse syms)))) form))) @@ -880,7 +891,8 @@ (let ((sym (gensym))) (push sym syms) (push (list sym arg) lets))))) - (list 'LET* (nreverse lets) (list* (car form) (nreverse syms))))))) + (list 'LET* (nreverse lets) + (list* (car form) (nreverse syms))))))) form))) (defknown p1-function-call (t) t) @@ -903,7 +915,8 @@ (let ((explain *explain*)) (when (and explain (memq :calls explain)) (format t "; inlining call to local function ~S~%" op))) - (return-from p1-function-call (p1 (expand-inline form expansion)))))) + (return-from p1-function-call + (p1 (expand-inline form expansion)))))) ;; FIXME (dformat t "local function assumed not single-valued~%") From ehuelsmann at common-lisp.net Sat May 16 09:02:24 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 05:02:24 -0400 Subject: [armedbear-cvs] r11880 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 16 05:02:21 2009 New Revision: 11880 Log: Remove the KIND slot from the COMPILAND structure: ever since we stopped compiling XEPs, we don't distinguish :EXTERNAL and :INTERNAL compilands anymore. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat May 16 05:02:21 2009 @@ -8018,9 +8018,9 @@ (*child-p* (not (null (compiland-parent compiland)))) (descriptor (analyze-args compiland)) - (execute-method-name (if (eq (compiland-kind compiland) :external) - "execute" "_execute")) - (execute-method (make-method :name execute-method-name + (execute-method (make-method :name (if (and *child-p* + *closure-variables*) + "_execute" "execute") :descriptor descriptor)) (*code* ()) (*register* 1) ;; register 0: "this" pointer @@ -8233,8 +8233,6 @@ (*child-p* (if *closure-variables* (progn - (setf execute-method-name - (setf (method-name execute-method) "_execute")) (setf (method-name-index execute-method) (pool-name (method-name execute-method))) (setf (method-descriptor-index execute-method) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat May 16 05:02:21 2009 @@ -153,7 +153,6 @@ (defstruct compiland name - (kind :external) ; :INTERNAL or :EXTERNAL lambda-expression arg-vars ; variables for lambda arguments free-specials ; From ehuelsmann at common-lisp.net Sat May 16 09:24:52 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 05:24:52 -0400 Subject: [armedbear-cvs] r11881 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 16 05:24:51 2009 New Revision: 11881 Log: Stop using CompiledClosure as a proxy for ClosureTemplateFunctions: they instances hold a copy of the closure array already. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sat May 16 05:24:51 2009 @@ -1189,14 +1189,7 @@ ClosureBinding[] context) throws ConditionThrowable { - ClosureTemplateFunction ctf = ((ClosureTemplateFunction) template).dup(); - ctf.setContext(context); - CompiledClosure result = new CompiledClosure(ctf, context); - LispObject classBytes = - getf(ctf.getPropertyList(), Symbol.CLASS_BYTES, NIL); - if (classBytes != NIL) - result.setPropertyList(list(Symbol.CLASS_BYTES, classBytes)); - return result; + return ((ClosureTemplateFunction)template).dup().setContext(context); } public static final String safeWriteToString(LispObject obj) Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat May 16 05:24:51 2009 @@ -2439,6 +2439,13 @@ LispObject name = ((CompiledClosure)arg).getLambdaName(); value3 = name != null ? name : NIL; } + else if (arg instanceof ClosureTemplateFunction) + { + value1 = NIL; + value2 = T; + LispObject name = ((ClosureTemplateFunction)arg).getLambdaName(); + value3 = name != null ? name : NIL; + } else if (arg instanceof Closure && !(arg instanceof CompiledFunction)) { Closure closure = (Closure) arg; Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat May 16 05:24:51 2009 @@ -241,7 +241,6 @@ (defconstant +lisp-return-class+ "org/armedbear/lisp/Return") (defconstant +lisp-go-class+ "org/armedbear/lisp/Go") (defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction") -(defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure") (defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction") (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") (defconstant +lisp-hash-table-class+ "org/armedbear/lisp/HashTable") @@ -4984,8 +4983,7 @@ (duplicate-closure-array *current-compiland*) (emit-invokestatic +lisp-class+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) - +lisp-object+) - (emit 'checkcast +lisp-compiled-closure-class+)) + +lisp-object+)) ; Stack: compiled-closure (t (aver nil))) ;; Shouldn't happen. From ehuelsmann at common-lisp.net Sat May 16 16:44:33 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 12:44:33 -0400 Subject: [armedbear-cvs] r11882 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 16 12:44:29 2009 New Revision: 11882 Log: Remove the last of the _execute() methods: By loading the closure array off the 'ctx' slot in the method, it's no longer required to do extra function calls just to add it to the parameter list. Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Sat May 16 12:44:29 2009 @@ -62,128 +62,41 @@ } - - // execute methods have the semantic meaning - // "evaluate this object" - @Override - public final LispObject execute() throws ConditionThrowable - { - return _execute(ctx); - } - - @Override - public final LispObject execute(LispObject arg) throws ConditionThrowable - { - return _execute(ctx, arg); - } - - @Override - public final LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return _execute(ctx, first, second); - } - - @Override - public final LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - return _execute(ctx, first, second, third); - } - - @Override - public final LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - return _execute(ctx, first, second, third, fourth); - } - - @Override - public final LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - return _execute(ctx, first, second, third, fourth, fifth); - } - - @Override - public final LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - return _execute(ctx, first, second, third, fourth, fifth, sixth); - } - - @Override - public final LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - return _execute(ctx, first, second, third, fourth, fifth, sixth, seventh); - } - - @Override - public final LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - return _execute(ctx, first, second, third, fourth, fifth, - sixth, seventh, eighth); - } - - @Override - public final LispObject execute(LispObject[] args) - throws ConditionThrowable - { - return _execute(ctx, args); - } - private final LispObject notImplemented() throws ConditionThrowable { return error(new WrongNumberOfArgumentsException(this)); } - // _execute methods have the semantic meaning - // "evaluate this template with these values" - // Zero args. - public LispObject _execute(ClosureBinding[] context) throws ConditionThrowable + public LispObject execute() throws ConditionThrowable { LispObject[] args = new LispObject[0]; - return _execute(context, args); + return execute(args); } // One arg. - public LispObject _execute(ClosureBinding[] context, LispObject first) + public LispObject execute( LispObject first) throws ConditionThrowable { LispObject[] args = new LispObject[1]; args[0] = first; - return _execute(context, args); + return execute(args); } // Two args. - public LispObject _execute(ClosureBinding[] context, LispObject first, + public LispObject execute( LispObject first, LispObject second) throws ConditionThrowable { LispObject[] args = new LispObject[2]; args[0] = first; args[1] = second; - return _execute(context, args); + return execute(args); } // Three args. - public LispObject _execute(ClosureBinding[] context, LispObject first, + public LispObject execute( LispObject first, LispObject second, LispObject third) throws ConditionThrowable { @@ -191,11 +104,11 @@ args[0] = first; args[1] = second; args[2] = third; - return _execute(context, args); + return execute(args); } // Four args. - public LispObject _execute(ClosureBinding[] context, LispObject first, + public LispObject execute( LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable @@ -205,11 +118,11 @@ args[1] = second; args[2] = third; args[3] = fourth; - return _execute(context, args); + return execute(args); } // Five args. - public LispObject _execute(ClosureBinding[] context, LispObject first, + public LispObject execute( LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) throws ConditionThrowable @@ -220,11 +133,11 @@ args[2] = third; args[3] = fourth; args[4] = fifth; - return _execute(context, args); + return execute(args); } // Six args. - public LispObject _execute(ClosureBinding[] context, LispObject first, + public LispObject execute( LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) @@ -237,11 +150,11 @@ args[3] = fourth; args[4] = fifth; args[5] = sixth; - return _execute(context, args); + return execute(args); } // Seven args. - public LispObject _execute(ClosureBinding[] context, LispObject first, + public LispObject execute( LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh) @@ -255,11 +168,11 @@ args[4] = fifth; args[5] = sixth; args[6] = seventh; - return _execute(context, args); + return execute(args); } // Eight args. - public LispObject _execute(ClosureBinding[] context, LispObject first, + public LispObject execute( LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh, @@ -275,11 +188,11 @@ args[5] = sixth; args[6] = seventh; args[7] = eighth; - return _execute(context, args); + return execute(args); } // Arg array. - public LispObject _execute(ClosureBinding[] context, LispObject[] args) + public LispObject execute(LispObject[] args) throws ConditionThrowable { return notImplemented(); Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat May 16 12:44:29 2009 @@ -7858,31 +7858,13 @@ (setf *using-arg-array* t) (setf *hairy-arglist-p* t) (return-from analyze-args - (if *closure-variables* - (get-descriptor (list +closure-binding-array+ - +lisp-object-array+) - +lisp-object+) - (get-descriptor (list +lisp-object-array+) - +lisp-object+)))) - (cond (*closure-variables* - (return-from analyze-args - (cond ((<= arg-count call-registers-limit) - (get-descriptor (list* +closure-binding-array+ - (lisp-object-arg-types arg-count)) - +lisp-object+)) - (t (setf *using-arg-array* t) - (setf (compiland-arity compiland) arg-count) - (get-descriptor (list +closure-binding-array+ +lisp-object-array+) ;; FIXME - +lisp-object+))))) - (t - (return-from analyze-args - (cond ((<= arg-count call-registers-limit) - (get-descriptor (lisp-object-arg-types arg-count) - +lisp-object+)) - (t (setf *using-arg-array* t) - (setf (compiland-arity compiland) arg-count) - (get-descriptor (list +lisp-object-array+) - +lisp-object+))))))) ;; FIXME + (get-descriptor (list +lisp-object-array+) +lisp-object+))) + (return-from analyze-args + (cond ((<= arg-count call-registers-limit) + (get-descriptor (lisp-object-arg-types arg-count) +lisp-object+)) + (t (setf *using-arg-array* t) + (setf (compiland-arity compiland) arg-count) + (get-descriptor (list +lisp-object-array+) +lisp-object+))))) (when (or (memq '&KEY args) (memq '&OPTIONAL args) (memq '&REST args)) @@ -8016,9 +7998,7 @@ (*child-p* (not (null (compiland-parent compiland)))) (descriptor (analyze-args compiland)) - (execute-method (make-method :name (if (and *child-p* - *closure-variables*) - "_execute" "execute") + (execute-method (make-method :name "execute" :descriptor descriptor)) (*code* ()) (*register* 1) ;; register 0: "this" pointer @@ -8041,12 +8021,6 @@ (setf (method-descriptor-index execute-method) (pool-name (method-descriptor execute-method))) - (when (and *closure-variables* *child-p*) - (setf (compiland-closure-register compiland) - (allocate-register)) ;; register 1: the closure array - (dformat t "p2-compiland 1 closure register = ~S~%" - (compiland-closure-register compiland))) - (when *using-arg-array* (setf (compiland-argument-register compiland) (allocate-register))) @@ -8064,19 +8038,25 @@ ;; Reserve the next available slot for the thread register. (setf *thread* (allocate-register)) - (when (and *closure-variables* (not *child-p*)) + (when *closure-variables* (setf (compiland-closure-register compiland) (allocate-register)) (dformat t "p2-compiland 2 closure register = ~S~%" (compiland-closure-register compiland))) (when *closure-variables* - (cond - ((not *child-p*) - ;; if we're the ultimate parent: create the closure array - (emit-push-constant-int (length *closure-variables*)) - (emit 'anewarray +closure-binding-class+)) - (local-closure-vars - (duplicate-closure-array compiland)))) + (if (not *child-p*) + (progn + ;; if we're the ultimate parent: create the closure array + (emit-push-constant-int (length *closure-variables*)) + (emit 'anewarray +closure-binding-class+)) + (progn + (aload 0) + (emit 'getfield +lisp-ctf-class+ "ctx" + +closure-binding-array+) + (when local-closure-vars + ;; in all other cases, it gets stored in the register below + (emit 'astore (compiland-closure-register compiland)) + (duplicate-closure-array compiland))))) ;; Move args from their original registers to the closure variables array (when (or closure-args @@ -8117,7 +8097,7 @@ (list +lisp-object+)) (emit 'aastore))))) - (when (or local-closure-vars (and *closure-variables* (not *child-p*))) + (when *closure-variables* (aver (not (null (compiland-closure-register compiland)))) (astore (compiland-closure-register compiland)) (dformat t "~S done moving arguments to closure array~%" From ehuelsmann at common-lisp.net Sat May 16 17:59:41 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 13:59:41 -0400 Subject: [armedbear-cvs] r11883 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 16 13:59:40 2009 New Revision: 11883 Log: Remove CompiledClosure; Rename ClosureTemplateFunction to CompiledClosure, as it is no longer a template: it holds the closure context. Added: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java - copied, changed from r11882, /trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Removed: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Copied: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java (from r11882, /trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java) ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Sat May 16 13:59:40 2009 @@ -1,5 +1,5 @@ /* - * ClosureTemplateFunction.java + * CompiledClosure.java * * Copyright (C) 2004-2005 Peter Graves * $Id$ @@ -33,29 +33,29 @@ package org.armedbear.lisp; -public class ClosureTemplateFunction extends Closure +public class CompiledClosure extends Closure implements Cloneable { public ClosureBinding[] ctx; - public ClosureTemplateFunction(LispObject lambdaList) + public CompiledClosure(LispObject lambdaList) throws ConditionThrowable { super(list(Symbol.LAMBDA, lambdaList), null); } - final public ClosureTemplateFunction setContext(ClosureBinding[] context) + final public CompiledClosure setContext(ClosureBinding[] context) { ctx = context; return this; } - final public ClosureTemplateFunction dup() + final public CompiledClosure dup() { - ClosureTemplateFunction result = null; + CompiledClosure result = null; try { - result = (ClosureTemplateFunction)super.clone(); + result = (CompiledClosure)super.clone(); } catch (CloneNotSupportedException e) { } return result; Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sat May 16 13:59:40 2009 @@ -1189,7 +1189,7 @@ ClosureBinding[] context) throws ConditionThrowable { - return ((ClosureTemplateFunction)template).dup().setContext(context); + return ((CompiledClosure)template).dup().setContext(context); } public static final String safeWriteToString(LispObject obj) Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat May 16 13:59:40 2009 @@ -2439,13 +2439,6 @@ LispObject name = ((CompiledClosure)arg).getLambdaName(); value3 = name != null ? name : NIL; } - else if (arg instanceof ClosureTemplateFunction) - { - value1 = NIL; - value2 = T; - LispObject name = ((ClosureTemplateFunction)arg).getLambdaName(); - value3 = name != null ? name : NIL; - } else if (arg instanceof Closure && !(arg instanceof CompiledFunction)) { Closure closure = (Closure) arg; Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat May 16 13:59:40 2009 @@ -240,7 +240,7 @@ (defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw") (defconstant +lisp-return-class+ "org/armedbear/lisp/Return") (defconstant +lisp-go-class+ "org/armedbear/lisp/Go") -(defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction") +(defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure") (defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction") (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") (defconstant +lisp-hash-table-class+ "org/armedbear/lisp/HashTable") @@ -1816,7 +1816,7 @@ (emit-constructor-lambda-name lambda-name) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 2))) - ((equal super +lisp-ctf-class+) + ((equal super +lisp-compiled-closure-class+) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 1))) (t @@ -3036,7 +3036,7 @@ (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* - (emit 'checkcast +lisp-ctf-class+) + (emit 'checkcast +lisp-compiled-closure-class+) (duplicate-closure-array compiland) (emit-invokestatic +lisp-class+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) @@ -4856,7 +4856,7 @@ (when (compiland-closure-register parent) (dformat t "(compiland-closure-register parent) = ~S~%" (compiland-closure-register parent)) - (emit 'checkcast +lisp-ctf-class+) + (emit 'checkcast +lisp-compiled-closure-class+) (duplicate-closure-array parent) (emit-invokestatic +lisp-class+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) @@ -5016,7 +5016,7 @@ ; Stack: template-function (when (compiland-closure-register *current-compiland*) - (emit 'checkcast +lisp-ctf-class+) + (emit 'checkcast +lisp-compiled-closure-class+) (duplicate-closure-array *current-compiland*) (emit-invokestatic +lisp-class+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) @@ -8051,7 +8051,7 @@ (emit 'anewarray +closure-binding-class+)) (progn (aload 0) - (emit 'getfield +lisp-ctf-class+ "ctx" + (emit 'getfield +lisp-compiled-closure-class+ "ctx" +closure-binding-array+) (when local-closure-vars ;; in all other cases, it gets stored in the register below @@ -8215,7 +8215,7 @@ (pool-name (method-name execute-method))) (setf (method-descriptor-index execute-method) (pool-name (method-descriptor execute-method))) - +lisp-ctf-class+) + +lisp-compiled-closure-class+) (if *hairy-arglist-p* +lisp-compiled-function-class+ +lisp-primitive-class+))) From ehuelsmann at common-lisp.net Sat May 16 18:02:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 14:02:02 -0400 Subject: [armedbear-cvs] r11884 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 16 14:02:01 2009 New Revision: 11884 Log: Update FASL version to 31 after the last incompatible changes. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sat May 16 14:02:01 2009 @@ -352,14 +352,14 @@ // ### *fasl-version* // internal symbol private static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(30)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(31)); // ### *fasl-anonymous-package* // internal symbol /** * This variable gets bound to a package with no name in which the * reader can intern its uninterned symbols. - * + * */ public static final Symbol _FASL_ANONYMOUS_PACKAGE_ = internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL); From ehuelsmann at common-lisp.net Sat May 16 19:03:22 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 15:03:22 -0400 Subject: [armedbear-cvs] r11885 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 16 15:03:21 2009 New Revision: 11885 Log: p2-compiland cleanup. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat May 16 15:03:21 2009 @@ -1762,7 +1762,7 @@ name-index descriptor-index) -(defstruct (java-method (:conc-name method-) (:constructor make-method)) +(defstruct (java-method (:conc-name method-) (:constructor %make-method)) access-flags name descriptor @@ -1773,6 +1773,14 @@ code handlers) +(defun make-method (&rest args &key descriptor name + descriptor-index name-index + &allow-other-keys) + (apply #'%make-method + (list* :descriptor-index (or descriptor-index (pool-name descriptor)) + :name-index (or name-index (pool-name name)) + args))) + (defun emit-constructor-lambda-name (lambda-name) (cond ((and lambda-name (symbolp lambda-name) (symbol-package (truly-the symbol lambda-name))) (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name)))) @@ -1800,8 +1808,6 @@ :descriptor "()V")) (*code* ()) (*handlers* nil)) - (setf (method-name-index constructor) (pool-name (method-name constructor))) - (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor))) (setf (method-max-locals constructor) 1) (aload 0) ;; this (cond ((equal super +lisp-compiled-function-class+) @@ -8008,7 +8014,6 @@ (*thread* nil) (*initialize-thread-var* nil) - (super nil) (label-START (gensym))) (dolist (var (compiland-arg-vars compiland)) @@ -8016,11 +8021,6 @@ (dolist (var (compiland-free-specials compiland)) (push var *visible-variables*)) - (setf (method-name-index execute-method) - (pool-name (method-name execute-method))) - (setf (method-descriptor-index execute-method) - (pool-name (method-descriptor execute-method))) - (when *using-arg-array* (setf (compiland-argument-register compiland) (allocate-register))) @@ -8040,8 +8040,8 @@ (when *closure-variables* (setf (compiland-closure-register compiland) (allocate-register)) - (dformat t "p2-compiland 2 closure register = ~S~%" - (compiland-closure-register compiland))) + (dformat t "p2-compiland 2 closure register = ~S~%" + (compiland-closure-register compiland))) (when *closure-variables* (if (not *child-p*) @@ -8198,31 +8198,19 @@ ;; Remove handler if its protected range is empty. (setf *handlers* - (delete-if (lambda (handler) (eql (symbol-value (handler-from handler)) - (symbol-value (handler-to handler)))) + (delete-if (lambda (handler) + (eql (symbol-value (handler-from handler)) + (symbol-value (handler-to handler)))) *handlers*)) (setf (method-max-locals execute-method) *registers-allocated*) (setf (method-handlers execute-method) (nreverse *handlers*)) (setf (class-file-superclass class-file) - (cond (super - super) - (*child-p* - (if *closure-variables* - (progn - (setf (method-name-index execute-method) - (pool-name (method-name execute-method))) - (setf (method-descriptor-index execute-method) - (pool-name (method-descriptor execute-method))) - +lisp-compiled-closure-class+) - (if *hairy-arglist-p* - +lisp-compiled-function-class+ - +lisp-primitive-class+))) - (*hairy-arglist-p* - +lisp-compiled-function-class+) - (t - +lisp-primitive-class+))) + (cond + ((and *child-p* *closure-variables*) +lisp-compiled-closure-class+) + (*hairy-arglist-p* +lisp-compiled-function-class+) + (t +lisp-primitive-class+))) (setf (class-file-lambda-list class-file) args) From ehuelsmann at common-lisp.net Sat May 16 19:31:56 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 15:31:56 -0400 Subject: [armedbear-cvs] r11886 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 16 15:31:53 2009 New Revision: 11886 Log: Mixed p2-compiland cleanup. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat May 16 15:31:53 2009 @@ -8104,10 +8104,12 @@ (compiland-name compiland))) ;; If applicable, move args from arg array to registers. - (when (and *using-arg-array* - (not (or *closure-variables* *child-p*))) + (when *using-arg-array* (dolist (variable (compiland-arg-vars compiland)) - (unless (variable-special-p variable) + (unless (or (variable-special-p variable) + (null (variable-index variable)) ;; not in the array anymore + (< (+ (variable-reads variable) + (variable-writes variable)) 2)) (let ((register (allocate-register))) (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) @@ -8132,27 +8134,23 @@ (label label-START) (dolist (variable (compiland-arg-vars compiland)) (when (variable-special-p variable) + (emit-push-current-thread) + (emit-push-variable-name variable) (cond ((variable-register variable) - (emit-push-current-thread) - (emit-push-variable-name variable) (aload (variable-register variable)) - (emit-invokevirtual +lisp-thread-class+ "bindSpecial" - (list +lisp-symbol+ +lisp-object+) nil) (setf (variable-register variable) nil)) ((variable-index variable) - (emit-push-current-thread) - (emit-push-variable-name variable) (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) (emit 'aaload) - (emit-invokevirtual +lisp-thread-class+ "bindSpecial" - (list +lisp-symbol+ +lisp-object+) nil) - (setf (variable-index variable) nil)))))) + (setf (variable-index variable) nil))) + (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (list +lisp-symbol+ +lisp-object+) nil)))) (compile-progn-body body 'stack) (when (compiland-environment-register compiland) - (restore-environment-and-make-handler + (restore-environment-and-make-handler (compiland-environment-register compiland) label-START)) (unless *code* From ehuelsmann at common-lisp.net Sat May 16 20:06:05 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 May 2009 16:06:05 -0400 Subject: [armedbear-cvs] r11887 - branches/fewer-executes Message-ID: Author: ehuelsmann Date: Sat May 16 16:06:03 2009 New Revision: 11887 Log: Create a branch to remove most of the n-ary execute() functions. Added: branches/fewer-executes/ - copied from r11886, /trunk/ From ehuelsmann at common-lisp.net Sun May 17 06:13:39 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 May 2009 02:13:39 -0400 Subject: [armedbear-cvs] r11888 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 17 02:13:37 2009 New Revision: 11888 Log: Fix DISASSEMBLE.5: CompiledClosure should return T when asked if it's of type COMPILED-FUNCTION. Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Sun May 17 02:13:37 2009 @@ -61,6 +61,13 @@ return result; } + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.COMPILED_FUNCTION) + return T; + return super.typep(typeSpecifier); + } private final LispObject notImplemented() throws ConditionThrowable { From vvoutilainen at common-lisp.net Sun May 17 11:36:43 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 17 May 2009 07:36:43 -0400 Subject: [armedbear-cvs] r11889 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun May 17 07:36:40 2009 New Revision: 11889 Log: Remove CompiledFunction, we don't need it. Removed: trunk/abcl/src/org/armedbear/lisp/CompiledFunction.java Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Sun May 17 07:36:40 2009 @@ -204,4 +204,35 @@ { return notImplemented(); } + + // ### load-compiled-function + private static final Primitive LOAD_COMPILED_FUNCTION = + new Primitive("load-compiled-function", PACKAGE_SYS, true, "pathname") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + String namestring = null; + if (arg instanceof Pathname) + namestring = ((Pathname)arg).getNamestring(); + else if (arg instanceof AbstractString) + namestring = arg.getStringValue(); + if (namestring != null) + return loadCompiledFunction(namestring); + return error(new LispError("Unable to load " + arg.writeToString())); + } + }; + + // ### varlist + private static final Primitive VARLIST = + new Primitive("varlist", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Closure) + return ((Closure)arg).getVariableList(); + return type_error(arg, Symbol.COMPILED_FUNCTION); + } + }; } 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 May 17 07:36:40 2009 @@ -2518,7 +2518,7 @@ loadClass("org.armedbear.lisp.Primitives"); loadClass("org.armedbear.lisp.SpecialOperators"); loadClass("org.armedbear.lisp.Extensions"); - loadClass("org.armedbear.lisp.CompiledFunction"); + loadClass("org.armedbear.lisp.CompiledClosure"); loadClass("org.armedbear.lisp.Autoload"); loadClass("org.armedbear.lisp.AutoloadMacro"); loadClass("org.armedbear.lisp.cxr"); Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sun May 17 07:36:40 2009 @@ -352,7 +352,7 @@ // ### *fasl-version* // internal symbol private static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(31)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(32)); // ### *fasl-anonymous-package* // internal symbol Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun May 17 07:36:40 2009 @@ -2439,7 +2439,7 @@ LispObject name = ((CompiledClosure)arg).getLambdaName(); value3 = name != null ? name : NIL; } - else if (arg instanceof Closure && !(arg instanceof CompiledFunction)) + else if (arg instanceof Closure) { Closure closure = (Closure) arg; LispObject expr = closure.getBody(); 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 May 17 07:36:40 2009 @@ -241,7 +241,6 @@ (defconstant +lisp-return-class+ "org/armedbear/lisp/Return") (defconstant +lisp-go-class+ "org/armedbear/lisp/Go") (defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure") -(defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction") (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") (defconstant +lisp-hash-table-class+ "org/armedbear/lisp/HashTable") (defconstant +lisp-eql-hash-table-class+ "org/armedbear/lisp/EqlHashTable") @@ -1810,15 +1809,7 @@ (*handlers* nil)) (setf (method-max-locals constructor) 1) (aload 0) ;; this - (cond ((equal super +lisp-compiled-function-class+) - (emit-constructor-lambda-name lambda-name) - (emit-constructor-lambda-list args) - (emit-push-nil) ;; body - (emit 'aconst_null) ;; environment - (emit-invokespecial-init super - (list +lisp-object+ +lisp-object+ - +lisp-object+ +lisp-environment+))) - ((equal super +lisp-primitive-class+) + (cond ((equal super +lisp-primitive-class+) (emit-constructor-lambda-name lambda-name) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 2))) @@ -8207,7 +8198,7 @@ (setf (class-file-superclass class-file) (cond ((and *child-p* *closure-variables*) +lisp-compiled-closure-class+) - (*hairy-arglist-p* +lisp-compiled-function-class+) + (*hairy-arglist-p* +lisp-compiled-closure-class+) (t +lisp-primitive-class+))) (setf (class-file-lambda-list class-file) args) From vvoutilainen at common-lisp.net Sun May 17 13:16:39 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 17 May 2009 09:16:39 -0400 Subject: [armedbear-cvs] r11890 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun May 17 09:16:37 2009 New Revision: 11890 Log: Don't repeat class names in p2-compiland, convert cond to if. 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 May 17 09:16:37 2009 @@ -8196,10 +8196,10 @@ (setf (method-handlers execute-method) (nreverse *handlers*)) (setf (class-file-superclass class-file) - (cond - ((and *child-p* *closure-variables*) +lisp-compiled-closure-class+) - (*hairy-arglist-p* +lisp-compiled-closure-class+) - (t +lisp-primitive-class+))) + (if (or *hairy-arglist-p* + (and *child-p* *closure-variables*)) + +lisp-compiled-closure-class+ + +lisp-primitive-class+)) (setf (class-file-lambda-list class-file) args) From ehuelsmann at common-lisp.net Sun May 17 13:17:14 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 May 2009 09:17:14 -0400 Subject: [armedbear-cvs] r11891 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 17 09:17:11 2009 New Revision: 11891 Log: Add docstring and reindent DECLARE-OBJECT. 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 May 17 09:17:11 2009 @@ -2193,12 +2193,15 @@ (declaim (ftype (function (t &optional t) string) declare-object)) (defun declare-object (obj &optional (obj-ref +lisp-object+) obj-class) + "Stores the object OBJ in the object-lookup-table, +loading the object value into a field upon class-creation time. + +The field type of the object is specified by OBJ-REF." (let ((key (symbol-name (gensym "OBJ")))) (remember key obj) (let* ((g1 (declare-string key)) (g2 (symbol-name (gensym "O2BJ")))) - (let* ( - (*code* *static-code*)) + (let* ((*code* *static-code*)) (declare-field g2 obj-ref) (emit 'getstatic *this-class* g1 +lisp-simple-string+) (emit-invokestatic +lisp-class+ "recall" From ehuelsmann at common-lisp.net Sun May 17 14:38:45 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 May 2009 10:38:45 -0400 Subject: [armedbear-cvs] r11892 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 17 10:38:44 2009 New Revision: 11892 Log: Re-use fields of objects declared previously within the same class file, instead of creating separate fields for every reference. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun May 17 10:38:44 2009 @@ -2197,20 +2197,23 @@ loading the object value into a field upon class-creation time. The field type of the object is specified by OBJ-REF." - (let ((key (symbol-name (gensym "OBJ")))) - (remember key obj) - (let* ((g1 (declare-string key)) - (g2 (symbol-name (gensym "O2BJ")))) - (let* ((*code* *static-code*)) - (declare-field g2 obj-ref) - (emit 'getstatic *this-class* g1 +lisp-simple-string+) - (emit-invokestatic +lisp-class+ "recall" - (list +lisp-simple-string+) +lisp-object+) - (when (and obj-class (string/= obj-class +lisp-object-class+)) - (emit 'checkcast obj-class)) - (emit 'putstatic *this-class* g2 obj-ref) - (setf *static-code* *code*) - g2)))) + (let ((field-name (gethash1 obj *declared-objects*))) + (if field-name + field-name + (let ((key (symbol-name (gensym "OBJ")))) + (remember key obj) + (let* ((g1 (declare-string key)) + (g2 (symbol-name (gensym "O2BJ"))) + (*code* *static-code*)) + (declare-field g2 obj-ref) + (emit 'getstatic *this-class* g1 +lisp-simple-string+) + (emit-invokestatic +lisp-class+ "recall" + (list +lisp-simple-string+) +lisp-object+) + (when (and obj-class (string/= obj-class +lisp-object-class+)) + (emit 'checkcast obj-class)) + (emit 'putstatic *this-class* g2 obj-ref) + (setf *static-code* *code*) + (setf (gethash obj *declared-objects*) g2)))))) (defun declare-lambda (obj) (let* ((g (symbol-name (gensym "LAMBDA"))) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sun May 17 10:38:44 2009 @@ -87,6 +87,7 @@ (defvar *declared-integers* nil) (defvar *declared-floats* nil) (defvar *declared-doubles* nil) +(defvar *declared-objects* nil) (defstruct (class-file (:constructor %make-class-file)) pathname ; pathname of output file @@ -105,7 +106,8 @@ (strings (make-hash-table :test 'eq)) (integers (make-hash-table :test 'eql)) (floats (make-hash-table :test 'eql)) - (doubles (make-hash-table :test 'eql))) + (doubles (make-hash-table :test 'eql)) + (objects (make-hash-table :test 'eq))) (defun class-name-from-filespec (filespec) (let* ((name (pathname-name filespec))) @@ -137,7 +139,8 @@ (*declared-strings* (class-file-strings ,var)) (*declared-integers* (class-file-integers ,var)) (*declared-floats* (class-file-floats ,var)) - (*declared-doubles* (class-file-doubles ,var))) + (*declared-doubles* (class-file-doubles ,var)) + (*declared-objects* (class-file-objects ,var))) (progn , at body) (setf (class-file-pool ,var) *pool* (class-file-pool-count ,var) *pool-count* @@ -149,7 +152,8 @@ (class-file-strings ,var) *declared-strings* (class-file-integers ,var) *declared-integers* (class-file-floats ,var) *declared-floats* - (class-file-doubles ,var) *declared-doubles*)))) + (class-file-doubles ,var) *declared-doubles* + (class-file-objects ,var) *declared-objects*)))) (defstruct compiland name From ehuelsmann at common-lisp.net Mon May 18 18:02:43 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 18 May 2009 14:02:43 -0400 Subject: [armedbear-cvs] r11893 - branches/fewer-executes/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 18 14:02:39 2009 New Revision: 11893 Log: As per Ville's request, upload the progress with respect to the deletion of the execute methods. Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/AbstractArray.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Autoload.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Closure.java branches/fewer-executes/abcl/src/org/armedbear/lisp/CompiledFunction.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Condition.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Cons.java branches/fewer-executes/abcl/src/org/armedbear/lisp/DispatchMacroFunction.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Function.java branches/fewer-executes/abcl/src/org/armedbear/lisp/HashTable.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Interpreter.java branches/fewer-executes/abcl/src/org/armedbear/lisp/JProxy.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Java.java branches/fewer-executes/abcl/src/org/armedbear/lisp/JavaException.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Lisp.java branches/fewer-executes/abcl/src/org/armedbear/lisp/LispObject.java branches/fewer-executes/abcl/src/org/armedbear/lisp/LispThread.java branches/fewer-executes/abcl/src/org/armedbear/lisp/LogicalPathname.java branches/fewer-executes/abcl/src/org/armedbear/lisp/MacroObject.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Primitive.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Primitives.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Profiler.java branches/fewer-executes/abcl/src/org/armedbear/lisp/ReaderMacroFunction.java branches/fewer-executes/abcl/src/org/armedbear/lisp/SimpleCondition.java branches/fewer-executes/abcl/src/org/armedbear/lisp/SlimeInputStream.java branches/fewer-executes/abcl/src/org/armedbear/lisp/SlimeOutputStream.java branches/fewer-executes/abcl/src/org/armedbear/lisp/SlotClass.java branches/fewer-executes/abcl/src/org/armedbear/lisp/SpecialOperator.java branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardClass.java branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardGenericFunction.java branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardObject.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Stream.java branches/fewer-executes/abcl/src/org/armedbear/lisp/StructureObject.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Symbol.java branches/fewer-executes/abcl/src/org/armedbear/lisp/Time.java branches/fewer-executes/abcl/src/org/armedbear/lisp/ZeroRankArray.java Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/AbstractArray.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/AbstractArray.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/AbstractArray.java Mon May 18 14:02:39 2009 @@ -235,7 +235,7 @@ if (Symbol.PRINT_CIRCLE.symbolValue(thread) != NIL) { StringOutputStream stream = new StringOutputStream(); thread.execute(Symbol.OUTPUT_OBJECT.getSymbolFunction(), - AREF(index), stream); + new LispObject[] { AREF(index), stream }); sb.append(stream.getString().getStringValue()); } else sb.append(AREF(index).writeToString()); Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Autoload.java Mon May 18 14:02:39 2009 @@ -153,90 +153,6 @@ } @Override - public LispObject execute() throws ConditionThrowable - { - load(); - return symbol.execute(); - } - - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - load(); - return symbol.execute(arg); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - load(); - return symbol.execute(first, second); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - load(); - return symbol.execute(first, second, third); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - load(); - return symbol.execute(first, second, third, fourth); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - load(); - return symbol.execute(first, second, third, fourth, fifth); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - load(); - return symbol.execute(first, second, third, fourth, fifth, sixth); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - load(); - return symbol.execute(first, second, third, fourth, fifth, sixth, - seventh); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - load(); - return symbol.execute(first, second, third, fourth, fifth, sixth, - seventh, eighth); - } - - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { load(); Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Closure.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Closure.java Mon May 18 14:02:39 2009 @@ -371,18 +371,6 @@ return environment; } - @Override - public LispObject execute() throws ConditionThrowable - { - if (arity == 0) - { - return progn(executionBody, environment, - LispThread.currentThread()); - } - else - return execute(new LispObject[0]); - } - private final LispObject bindParametersAndExecute(LispObject... objects) throws ConditionThrowable { @@ -429,136 +417,6 @@ return execute(objects); } - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - if (minArgs == 1) - { - return bindParametersAndExecute(arg); - } - else - { - return invokeArrayExecute(arg); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - if (minArgs == 2) - { - return bindParametersAndExecute(first, second); - } - else - { - return invokeArrayExecute(first, second); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - if (minArgs == 3) - { - return bindParametersAndExecute(first, second, third); - } - else - { - return invokeArrayExecute(first, second, third); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - if (minArgs == 4) - { - return bindParametersAndExecute(first, second, third, fourth); - } - else - { - return invokeArrayExecute(first, second, third, fourth); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - if (minArgs == 5) - { - return bindParametersAndExecute(first, second, third, fourth, - fifth); - } - else - { - return invokeArrayExecute(first, second, third, fourth, fifth); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - if (minArgs == 6) - { - return bindParametersAndExecute(first, second, third, fourth, - fifth, sixth); - } - else - { - return invokeArrayExecute(first, second, third, fourth, fifth, - sixth); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - if (minArgs == 7) - { - return bindParametersAndExecute(first, second, third, fourth, - fifth, sixth, seventh); - } - else - { - return invokeArrayExecute(first, second, third, fourth, fifth, - sixth, seventh); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - if (minArgs == 8) - { - return bindParametersAndExecute(first, second, third, fourth, - fifth, sixth, seventh, eighth); - } - else - { - return invokeArrayExecute(first, second, third, fourth, fifth, - sixth, seventh, eighth); - } - } - private final void declareFreeSpecials(Environment ext) throws ConditionThrowable { Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/CompiledFunction.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/CompiledFunction.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/CompiledFunction.java Mon May 18 14:02:39 2009 @@ -60,124 +60,6 @@ } @Override - public LispObject execute() throws ConditionThrowable - { - LispObject[] args = new LispObject[0]; - return execute(args); - } - - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - LispObject[] args = new LispObject[1]; - args[0] = arg; - return execute(args); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - LispObject[] args = new LispObject[2]; - args[0] = first; - args[1] = second; - return execute(args); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - LispObject[] args = new LispObject[3]; - args[0] = first; - args[1] = second; - args[2] = third; - return execute(args); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - LispObject[] args = new LispObject[4]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - return execute(args); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - LispObject[] args = new LispObject[5]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - return execute(args); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - LispObject[] args = new LispObject[6]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - args[5] = sixth; - return execute(args); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - LispObject[] args = new LispObject[7]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - args[5] = sixth; - args[6] = seventh; - return execute(args); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - LispObject[] args = new LispObject[8]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - args[5] = sixth; - args[6] = seventh; - args[7] = eighth; - return execute(args); - } - - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { return error(new LispError("Not implemented.")); Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Condition.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Condition.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Condition.java Mon May 18 14:02:39 2009 @@ -197,7 +197,7 @@ if (formatControl instanceof Function) { StringOutputStream stream = new StringOutputStream(); - Symbol.APPLY.execute(formatControl, stream, getFormatArguments()); + Symbol.APPLY.execute(new LispObject[] { formatControl, stream, getFormatArguments() }); return stream.getString().getStringValue(); } if (formatControl instanceof AbstractString) @@ -205,7 +205,7 @@ LispObject f = Symbol.FORMAT.getSymbolFunction(); if (f == null || f instanceof Autoload) return format(formatControl, getFormatArguments()); - return Symbol.APPLY.execute(f, NIL, formatControl, getFormatArguments()).getStringValue(); + return Symbol.APPLY.execute(new LispObject[] { f, NIL, formatControl, getFormatArguments() }).getStringValue(); } } final int maxLevel; Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Cons.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Cons.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Cons.java Mon May 18 14:02:39 2009 @@ -470,126 +470,6 @@ } @Override - public LispObject execute() throws ConditionThrowable - { - if (car == Symbol.LAMBDA) - { - Closure closure = new Closure(this, new Environment()); - return closure.execute(); - } - return signalExecutionError(); - } - - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - if (car == Symbol.LAMBDA) - { - Closure closure = new Closure(this, new Environment()); - return closure.execute(arg); - } - return signalExecutionError(); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - if (car == Symbol.LAMBDA) - { - Closure closure = new Closure(this, new Environment()); - return closure.execute(first, second); - } - return signalExecutionError(); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - if (car == Symbol.LAMBDA) - { - Closure closure = new Closure(this, new Environment()); - return closure.execute(first, second, third); - } - return signalExecutionError(); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - if (car == Symbol.LAMBDA) - { - Closure closure = new Closure(this, new Environment()); - return closure.execute(first, second, third, fourth); - } - return signalExecutionError(); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - if (car == Symbol.LAMBDA) - { - Closure closure = new Closure(this, new Environment()); - return closure.execute(first, second, third, fourth, fifth); - } - return signalExecutionError(); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - if (car == Symbol.LAMBDA) - { - Closure closure = new Closure(this, new Environment()); - return closure.execute(first, second, third, fourth, fifth, sixth); - } - return signalExecutionError(); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - if (car == Symbol.LAMBDA) - { - Closure closure = new Closure(this, new Environment()); - return closure.execute(first, second, third, fourth, fifth, sixth, - seventh); - } - return signalExecutionError(); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - if (car == Symbol.LAMBDA) - { - Closure closure = new Closure(this, new Environment()); - return closure.execute(first, second, third, fourth, fifth, sixth, - seventh, eighth); - } - return signalExecutionError(); - } - - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { if (car == Symbol.LAMBDA) Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/DispatchMacroFunction.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/DispatchMacroFunction.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/DispatchMacroFunction.java Mon May 18 14:02:39 2009 @@ -62,17 +62,19 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) + public LispObject execute(LispObject[] args) throws ConditionThrowable { - Stream stream = inSynonymOf(first); - char c = LispCharacter.getValue(second); + if (args.length != 3) + return error(new WrongNumberOfArgumentsException(this)); + + Stream stream = inSynonymOf(args[0]); + char c = LispCharacter.getValue(args[1]); int n; - if (third == NIL) + if (args[2] == NIL) n = -1; else - n = Fixnum.getValue(third); + n = Fixnum.getValue(args[2]); return execute(stream, c, n); } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Function.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Function.java Mon May 18 14:02:39 2009 @@ -183,79 +183,6 @@ } @Override - public LispObject execute() throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { return error(new WrongNumberOfArgumentsException(this)); Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/HashTable.java Mon May 18 14:02:39 2009 @@ -279,7 +279,7 @@ HashEntry e = buckets[i]; while (e != null) { - function.execute(e.key, e.value); + function.execute(new LispObject[] { e.key, e.value }); e = e.next; } } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Interpreter.java Mon May 18 14:02:39 2009 @@ -335,7 +335,7 @@ Symbol TOP_LEVEL_LOOP = intern("TOP-LEVEL-LOOP", PACKAGE_TPL); LispObject tplFun = TOP_LEVEL_LOOP.getSymbolFunction(); if (tplFun instanceof Function) { - thread.execute(tplFun); + thread.execute(new LispObject[] { tplFun }); return; } // We only arrive here if something went wrong and we weren't able Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/JProxy.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/JProxy.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/JProxy.java Mon May 18 14:02:39 2009 @@ -187,7 +187,7 @@ } Object retVal = LispThread.currentThread().execute - (Symbol.APPLY, function, lispArgs.reverse()).javaInstance(); + (Symbol.APPLY, new LispObject[] { function, lispArgs.reverse() }).javaInstance(); //(function.execute(lispArgs)).javaInstance(); /* DOES NOT WORK due to autoboxing! if(retVal != null && !method.getReturnType().isAssignableFrom(retVal.getClass())) { @@ -200,7 +200,7 @@ private static final Primitive _JMAKE_INVOCATION_HANDLER = new Primitive("%jmake-invocation-handler", PACKAGE_JAVA, false, "function") { - + @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { int length = args.length; if (length != 1) { @@ -216,7 +216,7 @@ private static final Primitive _JMAKE_PROXY = new Primitive("%jmake-proxy", PACKAGE_JAVA, false, "interface invocation-handler") { - + @Override public LispObject execute(final LispObject[] args) throws ConditionThrowable { int length = args.length; if (length != 3) { Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Java.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Java.java Mon May 18 14:02:39 2009 @@ -399,11 +399,12 @@ error(new JavaException(t)); else Symbol.SIGNAL.execute( - condition, - Keyword.CAUSE, - JavaObject.getInstance(t), - Keyword.FORMAT_CONTROL, - new SimpleString(getMessage(t))); + new LispObject[] { + condition, + Keyword.CAUSE, + JavaObject.getInstance(t), + Keyword.FORMAT_CONTROL, + new SimpleString(getMessage(t)) }); } // Not reached. return NIL; @@ -464,11 +465,12 @@ error(new JavaException(t)); else Symbol.SIGNAL.execute( - condition, - Keyword.CAUSE, - JavaObject.getInstance(t), - Keyword.FORMAT_CONTROL, - new SimpleString(getMessage(t))); + new LispObject[] { + condition, + Keyword.CAUSE, + JavaObject.getInstance(t), + Keyword.FORMAT_CONTROL, + new SimpleString(getMessage(t)) }); } // Not reached. return NIL; @@ -518,11 +520,12 @@ error(new JavaException(t)); else Symbol.SIGNAL.execute( - condition, - Keyword.CAUSE, - JavaObject.getInstance(t), - Keyword.FORMAT_CONTROL, - new SimpleString(getMessage(t))); + new LispObject[] { + condition, + Keyword.CAUSE, + JavaObject.getInstance(t), + Keyword.FORMAT_CONTROL, + new SimpleString(getMessage(t)) }); } // Not reached. return NIL; @@ -576,11 +579,12 @@ error(new JavaException(t)); else Symbol.SIGNAL.execute( - condition, - Keyword.CAUSE, - JavaObject.getInstance(t), - Keyword.FORMAT_CONTROL, - new SimpleString(getMessage(t))); + new LispObject[] { + condition, + Keyword.CAUSE, + JavaObject.getInstance(t), + Keyword.FORMAT_CONTROL, + new SimpleString(getMessage(t)) }); } // Not reached. return NIL; @@ -658,11 +662,12 @@ error(new JavaException(t)); else Symbol.SIGNAL.execute( - condition, - Keyword.CAUSE, - JavaObject.getInstance(t), - Keyword.FORMAT_CONTROL, - new SimpleString(getMessage(t))); + new LispObject[] { + condition, + Keyword.CAUSE, + JavaObject.getInstance(t), + Keyword.FORMAT_CONTROL, + new SimpleString(getMessage(t)) }); } // Not reached. return null; Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/JavaException.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/JavaException.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/JavaException.java Mon May 18 14:02:39 2009 @@ -93,7 +93,7 @@ @Override public LispObject execute(LispObject arg) throws ConditionThrowable { - return Symbol.STD_SLOT_VALUE.execute(arg, Symbol.CAUSE); + return Symbol.STD_SLOT_VALUE.execute(new LispObject[] { arg, Symbol.CAUSE }); } }; } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Lisp.java Mon May 18 14:02:39 2009 @@ -140,49 +140,12 @@ fun.incrementCallCount(); try { - switch (args.length) - { - case 0: - result = fun.execute(); - break; - case 1: - result = fun.execute(args[0]); - break; - case 2: - result = fun.execute(args[0], args[1]); - break; - case 3: - result = fun.execute(args[0], args[1], args[2]); - break; - case 4: - result = fun.execute(args[0], args[1], args[2], args[3]); - break; - case 5: - result = fun.execute(args[0], args[1], args[2], args[3], - args[4]); - break; - case 6: - result = fun.execute(args[0], args[1], args[2], args[3], - args[4], args[5]); - break; - case 7: - result = fun.execute(args[0], args[1], args[2], args[3], - args[4], args[5], args[6]); - break; - case 8: - result = fun.execute(args[0], args[1], args[2], args[3], - args[4], args[5], args[6], args[7]); - break; - default: - result = fun.execute(args); - break; - } + return fun.execute(args); } finally { thread.setStack(stack); } - return result; } public static final LispObject macroexpand(LispObject form, @@ -239,7 +202,7 @@ expander.incrementCallCount(); LispObject hook = coerceToFunction(Symbol.MACROEXPAND_HOOK.symbolValue(thread)); - return thread.setValues(hook.execute(expander, form, env), + return thread.setValues(hook.execute(new LispObject[] {expander, form, env} ), T); } } @@ -273,7 +236,8 @@ LispObject result; try { - result = thread.execute(Symbol.EVAL.getSymbolFunction(), object); + result = thread.execute(Symbol.EVAL.getSymbolFunction(), + new LispObject[] { object }); } catch (OutOfMemoryError e) { @@ -334,13 +298,13 @@ public static final LispObject error(LispObject condition) throws ConditionThrowable { - return Symbol.ERROR.execute(condition); + return Symbol.ERROR.execute(new LispObject[] { condition }); } public static final LispObject error(LispObject condition, LispObject message) throws ConditionThrowable { - return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message); + return Symbol.ERROR.execute(new LispObject[] { condition, Keyword.FORMAT_CONTROL, message }); } public static final LispObject type_error(LispObject datum, @@ -360,7 +324,7 @@ public static final void handleInterrupt() throws ConditionThrowable { setInterrupted(false); - Symbol.BREAK.getSymbolFunction().execute(); + Symbol.BREAK.getSymbolFunction().execute(new LispObject[0]); setInterrupted(false); } @@ -465,79 +429,9 @@ LispThread thread) throws ConditionThrowable { - if (args == NIL) - return thread.execute(function); - LispObject first = eval(args.car(), env, thread); - args = ((Cons)args).cdr; - if (args == NIL) - { - thread._values = null; - return thread.execute(function, first); - } - LispObject second = eval(args.car(), env, thread); - args = ((Cons)args).cdr; - if (args == NIL) - { - thread._values = null; - return thread.execute(function, first, second); - } - LispObject third = eval(args.car(), env, thread); - args = ((Cons)args).cdr; - if (args == NIL) - { - thread._values = null; - return thread.execute(function, first, second, third); - } - LispObject fourth = eval(args.car(), env, thread); - args = ((Cons)args).cdr; - if (args == NIL) - { - thread._values = null; - return thread.execute(function, first, second, third, fourth); - } - LispObject fifth = eval(args.car(), env, thread); - args = ((Cons)args).cdr; - if (args == NIL) - { - thread._values = null; - return thread.execute(function, first, second, third, fourth, fifth); - } - LispObject sixth = eval(args.car(), env, thread); - args = ((Cons)args).cdr; - if (args == NIL) - { - thread._values = null; - return thread.execute(function, first, second, third, fourth, fifth, - sixth); - } - LispObject seventh = eval(args.car(), env, thread); - args = ((Cons)args).cdr; - if (args == NIL) - { - thread._values = null; - return thread.execute(function, first, second, third, fourth, fifth, - sixth, seventh); - } - LispObject eighth = eval(args.car(), env, thread); - args = ((Cons)args).cdr; - if (args == NIL) - { - thread._values = null; - return thread.execute(function, first, second, third, fourth, fifth, - sixth, seventh, eighth); - } - // More than CALL_REGISTERS_MAX arguments. - final int length = args.length() + CALL_REGISTERS_MAX; + final int length = args.length(); LispObject[] array = new LispObject[length]; - array[0] = first; - array[1] = second; - array[2] = third; - array[3] = fourth; - array[4] = fifth; - array[5] = sixth; - array[6] = seventh; - array[7] = eighth; - for (int i = CALL_REGISTERS_MAX; i < length; i++) + for (int i = 0; i < length; i++) { array[i] = eval(args.car(), env, thread); args = args.cdr(); @@ -782,7 +676,8 @@ LispObject[] values = thread._values; thread._values = null; if (values == null) - return thread.execute(coerceToFunction(function), result); + return thread.execute(coerceToFunction(function), + new LispObject[] { result }); else return funcall(coerceToFunction(function), values, thread); } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/LispObject.java Mon May 18 14:02:39 2009 @@ -646,70 +646,6 @@ return error(new LispError()); } - public LispObject execute() throws ConditionThrowable - { - return type_error(this, Symbol.FUNCTION); - } - - public LispObject execute(LispObject arg) throws ConditionThrowable - { - return type_error(this, Symbol.FUNCTION); - } - - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return type_error(this, Symbol.FUNCTION); - } - - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - return type_error(this, Symbol.FUNCTION); - } - - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - return type_error(this, Symbol.FUNCTION); - } - - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - return type_error(this, Symbol.FUNCTION); - } - - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - return type_error(this, Symbol.FUNCTION); - } - - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - return type_error(this, Symbol.FUNCTION); - } - - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - return type_error(this, Symbol.FUNCTION); - } - public LispObject execute(LispObject[] args) throws ConditionThrowable { return type_error(this, Symbol.FUNCTION); @@ -718,32 +654,7 @@ // Used by COMPILE-MULTIPLE-VALUE-CALL. public LispObject dispatch(LispObject[] args) throws ConditionThrowable { - switch (args.length) - { - case 0: - return execute(); - case 1: - return execute(args[0]); - case 2: - return execute(args[0], args[1]); - case 3: - return execute(args[0], args[1], args[2]); - case 4: - return execute(args[0], args[1], args[2], args[3]); - case 5: - return execute(args[0], args[1], args[2], args[3], args[4]); - case 6: - return execute(args[0], args[1], args[2], args[3], args[4], - args[5]); - case 7: - return execute(args[0], args[1], args[2], args[3], args[4], - args[5], args[6]); - case 8: - return execute(args[0], args[1], args[2], args[3], args[4], - args[5], args[6], args[7]); - default: - return type_error(this, Symbol.FUNCTION); - } + return type_error(this, Symbol.FUNCTION); } public int intValue() throws ConditionThrowable Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/LispThread.java Mon May 18 14:02:39 2009 @@ -585,248 +585,6 @@ stack = NIL; } - @Override - public LispObject execute(LispObject function) throws ConditionThrowable - { - if (use_fast_calls) - return function.execute(); - - LispObject oldStack = stack; - pushStackFrame(function); - try { - return function.execute(); - } - finally { - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - stack = oldStack; - } - } - - @Override - public LispObject execute(LispObject function, LispObject arg) - throws ConditionThrowable - { - if (use_fast_calls) - return function.execute(arg); - - LispObject oldStack = stack; - pushStackFrame(function, arg); - try { - return function.execute(arg); - } - finally { - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - stack = oldStack; - } - } - - @Override - public LispObject execute(LispObject function, LispObject first, - LispObject second) - throws ConditionThrowable - { - if (use_fast_calls) - return function.execute(first, second); - - LispObject oldStack = stack; - pushStackFrame(function, first, second); - try { - return function.execute(first, second); - } - finally { - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - stack = oldStack; - } - } - - @Override - public LispObject execute(LispObject function, LispObject first, - LispObject second, LispObject third) - throws ConditionThrowable - { - if (use_fast_calls) - return function.execute(first, second, third); - - LispObject oldStack = stack; - pushStackFrame(function, first, second, third); - try { - return function.execute(first, second, third); - } - finally { - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - stack = oldStack; - } - } - - @Override - public LispObject execute(LispObject function, LispObject first, - LispObject second, LispObject third, - LispObject fourth) - throws ConditionThrowable - { - if (use_fast_calls) - return function.execute(first, second, third, fourth); - - LispObject oldStack = stack; - LispObject[] args = new LispObject[4]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - pushStackFrame(function, args); - try { - return function.execute(first, second, third, fourth); - } - finally { - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - stack = oldStack; - } - } - - @Override - public LispObject execute(LispObject function, LispObject first, - LispObject second, LispObject third, - LispObject fourth, LispObject fifth) - throws ConditionThrowable - { - if (use_fast_calls) - return function.execute(first, second, third, fourth, fifth); - - LispObject oldStack = stack; - LispObject[] args = new LispObject[5]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - pushStackFrame(function, args); - try { - return function.execute(first, second, third, fourth, fifth); - } - finally { - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - stack = oldStack; - } - } - - @Override - public LispObject execute(LispObject function, LispObject first, - LispObject second, LispObject third, - LispObject fourth, LispObject fifth, - LispObject sixth) - throws ConditionThrowable - { - if (use_fast_calls) - return function.execute(first, second, third, fourth, fifth, sixth); - - LispObject oldStack = stack; - LispObject[] args = new LispObject[6]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - args[5] = sixth; - pushStackFrame(function, args); - try { - return function.execute(first, second, third, fourth, fifth, sixth); - } - finally { - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - stack = oldStack; - } - } - - @Override - public LispObject execute(LispObject function, LispObject first, - LispObject second, LispObject third, - LispObject fourth, LispObject fifth, - LispObject sixth, LispObject seventh) - throws ConditionThrowable - { - if (use_fast_calls) - return function.execute(first, second, third, fourth, fifth, sixth, - seventh); - - LispObject oldStack = stack; - LispObject[] args = new LispObject[7]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - args[5] = sixth; - args[6] = seventh; - pushStackFrame(function, args); - try { - return function.execute(first, second, third, fourth, fifth, sixth, - seventh); - } - finally { - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - stack = oldStack; - } - } - - public LispObject execute(LispObject function, LispObject first, - LispObject second, LispObject third, - LispObject fourth, LispObject fifth, - LispObject sixth, LispObject seventh, - LispObject eighth) - throws ConditionThrowable - { - if (use_fast_calls) - return function.execute(first, second, third, fourth, fifth, sixth, - seventh, eighth); - - LispObject oldStack = stack; - LispObject[] args = new LispObject[8]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - args[5] = sixth; - args[6] = seventh; - args[7] = eighth; - pushStackFrame(function, args); - try { - return function.execute(first, second, third, fourth, fifth, sixth, - seventh, eighth); - } - finally { - if (profiling && sampling) { - if (sampleNow) - Profiler.sample(this); - } - stack = oldStack; - } - } - public LispObject execute(LispObject function, LispObject[] args) throws ConditionThrowable { Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/LogicalPathname.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/LogicalPathname.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/LogicalPathname.java Mon May 18 14:02:39 2009 @@ -99,7 +99,8 @@ else if (v.equals("NEWEST") || v.equals("newest")) version = Keyword.NEWEST; else - version = PACKAGE_CL.intern("PARSE-INTEGER").execute(new SimpleString(v)); + version = PACKAGE_CL.intern("PARSE-INTEGER") + .execute(new LispObject[] { new SimpleString(v) }); } else { String t = rest; if (t.equals("*")) @@ -139,7 +140,8 @@ public static Pathname translateLogicalPathname(LogicalPathname pathname) throws ConditionThrowable { - return (Pathname) Symbol.TRANSLATE_LOGICAL_PATHNAME.execute(pathname); + return (Pathname) Symbol.TRANSLATE_LOGICAL_PATHNAME + .execute(new LispObject[] { pathname }); } private static final LispObject parseDirectory(String s) Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/MacroObject.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/MacroObject.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/MacroObject.java Mon May 18 14:02:39 2009 @@ -48,79 +48,6 @@ } @Override - public LispObject execute() throws ConditionThrowable - { - return error(new UndefinedFunction(name)); - } - - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - return error(new UndefinedFunction(name)); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return error(new UndefinedFunction(name)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - return error(new UndefinedFunction(name)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - return error(new UndefinedFunction(name)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - return error(new UndefinedFunction(name)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - return error(new UndefinedFunction(name)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - return error(new UndefinedFunction(name)); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - return error(new UndefinedFunction(name)); - } - - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { return error(new UndefinedFunction(name)); Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Primitive.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Primitive.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Primitive.java Mon May 18 14:02:39 2009 @@ -93,121 +93,99 @@ return Symbol.COMPILED_FUNCTION; } - @Override public LispObject execute() throws ConditionThrowable { - LispObject[] args = new LispObject[0]; - return execute(args); + return error(new WrongNumberOfArgumentsException(this)); } - @Override public LispObject execute(LispObject arg) throws ConditionThrowable { - LispObject[] args = new LispObject[1]; - args[0] = arg; - return execute(args); + return error(new WrongNumberOfArgumentsException(this)); } - @Override public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { - LispObject[] args = new LispObject[2]; - args[0] = first; - args[1] = second; - return execute(args); + return error(new WrongNumberOfArgumentsException(this)); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable { - LispObject[] args = new LispObject[3]; - args[0] = first; - args[1] = second; - args[2] = third; - return execute(args); + return error(new WrongNumberOfArgumentsException(this)); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable { - LispObject[] args = new LispObject[4]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - return execute(args); + return error(new WrongNumberOfArgumentsException(this)); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) throws ConditionThrowable { - LispObject[] args = new LispObject[5]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - return execute(args); + return error(new WrongNumberOfArgumentsException(this)); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) throws ConditionThrowable { - LispObject[] args = new LispObject[6]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - args[5] = sixth; - return execute(args); + return error(new WrongNumberOfArgumentsException(this)); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh) throws ConditionThrowable { - LispObject[] args = new LispObject[7]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - args[5] = sixth; - args[6] = seventh; - return execute(args); + return error(new WrongNumberOfArgumentsException(this)); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh, LispObject eighth) throws ConditionThrowable { - LispObject[] args = new LispObject[8]; - args[0] = first; - args[1] = second; - args[2] = third; - args[3] = fourth; - args[4] = fifth; - args[5] = sixth; - args[6] = seventh; - args[7] = eighth; - return execute(args); + return error(new WrongNumberOfArgumentsException(this)); } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + switch (args.length) + { + case 0: + return execute(); + case 1: + return execute(args[0]); + case 2: + return execute(args[0], args[1]); + case 3: + return execute(args[0], args[1], args[2]); + case 4: + return execute(args[0], args[1], args[2], args[3]); + case 5: + return execute(args[0], args[1], args[2], args[3], args[4]); + case 6: + return execute(args[0], args[1], args[2], args[3], args[4], + args[5]); + case 7: + return execute(args[0], args[1], args[2], args[3], args[4], + args[5], args[6]); + case 8: + return execute(args[0], args[1], args[2], args[3], args[4], + args[5], args[6], args[7]); + default: + return error(new WrongNumberOfArgumentsException(this)); + } + } + } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Primitives.java Mon May 18 14:02:39 2009 @@ -48,19 +48,6 @@ return Fixnum.ONE; } @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - if (arg.numberp()) - return arg; - return type_error(arg, Symbol.NUMBER); - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return first.multiplyBy(second); - } - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { LispObject result = Fixnum.ONE; @@ -75,24 +62,11 @@ new Primitive(Symbol.SLASH, "numerator &rest denominators") { @Override - public LispObject execute() throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - return Fixnum.ONE.divideBy(arg); - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return first.divideBy(second); - } - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { + if (args.length == 0) + return error(new WrongNumberOfArgumentsException(this)); + LispObject result = args[0]; for (int i = 1; i < args.length; i++) result = result.divideBy(args[i]); @@ -105,26 +79,10 @@ new Primitive(Symbol.MIN, "&rest reals") { @Override - public LispObject execute() throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - if (arg.realp()) - return arg; - return type_error(arg, Symbol.REAL); - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return first.isLessThan(second) ? first : second; - } - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { + if (args.length == 0) + return error(new WrongNumberOfArgumentsException(this)); LispObject result = args[0]; if (!result.realp()) type_error(result, Symbol.REAL); @@ -142,26 +100,10 @@ new Primitive(Symbol.MAX, "&rest reals") { @Override - public LispObject execute() throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - if (arg.realp()) - return arg; - return type_error(arg, Symbol.REAL); - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return first.isGreaterThan(second) ? first : second; - } - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { + if (args.length == 0) + return error(new WrongNumberOfArgumentsException(this)); LispObject result = args[0]; if (!result.realp()) type_error(result, Symbol.REAL); @@ -355,34 +297,6 @@ new Primitive(Symbol.VALUES, "&rest object") { @Override - public LispObject execute() - { - return LispThread.currentThread().setValues(); - } - @Override - public LispObject execute(LispObject arg) - { - return LispThread.currentThread().setValues(arg); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - return LispThread.currentThread().setValues(first, second); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - { - return LispThread.currentThread().setValues(first, second, third); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - { - return LispThread.currentThread().setValues(first, second, third, - fourth); - } - @Override public LispObject execute(LispObject[] args) { return LispThread.currentThread().setValues(args); @@ -633,31 +547,6 @@ new Primitive(Symbol.PLUS, "&rest numbers") { @Override - public LispObject execute() - { - return Fixnum.ZERO; - } - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - if (arg.numberp()) - return arg; - return type_error(arg, Symbol.NUMBER); - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return first.add(second); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - return first.add(second).add(third); - } - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { LispObject result = Fixnum.ZERO; @@ -684,24 +573,12 @@ new Primitive(Symbol.MINUS, "minuend &rest subtrahends") { @Override - public LispObject execute() throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - return arg.negate(); - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return first.subtract(second); - } - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { + if (args.length == 0) + return error(new WrongNumberOfArgumentsException(this)); + if (args.length == 1) + return args[0].negate(); LispObject result = args[0]; for (int i = 1; i < args.length; i++) result = result.subtract(args[i]); @@ -943,65 +820,14 @@ new Primitive(Symbol.APPEND, "&rest lists") { @Override - public LispObject execute() - { - return NIL; - } - @Override - public LispObject execute(LispObject arg) - { - return arg; - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - if (first == NIL) - return second; - // APPEND is required to copy its first argument. - Cons result = new Cons(first.car()); - Cons splice = result; - first = first.cdr(); - while (first != NIL) - { - Cons temp = new Cons(first.car()); - splice.cdr = temp; - splice = temp; - first = first.cdr(); - } - splice.cdr = second; - return result; - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - if (first == NIL) - return execute(second, third); - Cons result = new Cons(first.car()); - Cons splice = result; - first = first.cdr(); - while (first != NIL) - { - Cons temp = new Cons(first.car()); - splice.cdr = temp; - splice = temp; - first = first.cdr(); - } - while (second != NIL) - { - Cons temp = new Cons(second.car()); - splice.cdr = temp; - splice = temp; - second = second.cdr(); - } - splice.cdr = third; - return result; - } - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { + if (args.length == 0) + return NIL; + + if (args.length == 1) + return args[0]; + Cons result = null; Cons splice = null; final int limit = args.length - 1; @@ -1046,38 +872,13 @@ new Primitive(Symbol.NCONC, "&rest lists") { @Override - public LispObject execute() - { - return NIL; - } - @Override - public LispObject execute(LispObject arg) - { - return arg; - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - if (first == NIL) - return second; - if (first instanceof Cons) - { - LispObject result = first; - Cons splice = null; - while (first instanceof Cons) - { - splice = (Cons) first; - first = splice.cdr; - } - splice.cdr = second; - return result; - } - return type_error(first, Symbol.LIST); - } - @Override public LispObject execute(LispObject[] array) throws ConditionThrowable { + if (array.length == 0) + return NIL; + if (array.length == 1) + return array[0]; + LispObject result = null; Cons splice = null; final int limit = array.length - 1; @@ -1122,34 +923,10 @@ new Primitive(Symbol.EQUALS, "&rest numbers") { @Override - public LispObject execute() throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - @Override - public LispObject execute(LispObject arg) - { - return T; - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return first.isEqualTo(second) ? T : NIL; - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - if (first.isEqualTo(second) && second.isEqualTo(third)) - return T; - else - return NIL; - } - @Override public LispObject execute(LispObject[] array) throws ConditionThrowable { + if (array.length == 0) + return error(new WrongNumberOfArgumentsException(this)); final int length = array.length; final LispObject obj = array[0]; for (int i = 1; i < length; i++) @@ -1611,8 +1388,8 @@ } if (currentSource == Keyword.TOP_LEVEL) { - Symbol.STYLE_WARN.execute(new SimpleString("redefining ~S at top level"), - arg); + Symbol.STYLE_WARN + .execute(new LispObject[] { new SimpleString("redefining ~S at top level"), arg }); } else @@ -1621,8 +1398,9 @@ thread.bindSpecial(Symbol._PACKAGE_, PACKAGE_CL); try { - Symbol.STYLE_WARN.execute(new SimpleString("redefining ~S in ~S"), - arg, currentSource); + Symbol.STYLE_WARN + .execute(new LispObject[] { new SimpleString("redefining ~S in ~S"), + arg, currentSource }); } finally { @@ -1656,8 +1434,8 @@ return type_error(name, FUNCTION_NAME); if (definition instanceof Function) { - Symbol.FSET.execute(name, definition, NIL, - ((Function)definition).getLambdaList()); + Symbol.FSET.execute(new LispObject[] { name, definition, NIL, + ((Function)definition).getLambdaList() }); return name; } return type_error(definition, Symbol.FUNCTION); @@ -2477,95 +2255,15 @@ public static final Primitive FUNCALL = new Primitive(Symbol.FUNCALL, "function &rest args") { - @Override - public LispObject execute() throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - return LispThread.currentThread().execute(arg); - } - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return LispThread.currentThread().execute(first, second); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - return LispThread.currentThread().execute(first, second, third); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - return LispThread.currentThread().execute(first, second, third, - fourth); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - return LispThread.currentThread().execute(first, second, third, - fourth, fifth); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - return LispThread.currentThread().execute(first, second, third, - fourth, fifth, sixth); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - return LispThread.currentThread().execute(first, second, third, - fourth, fifth, sixth, - seventh); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eigth) - throws ConditionThrowable - { - return LispThread.currentThread().execute(first, second, third, - fourth, fifth, sixth, - seventh, eigth); - } + // We don't need to implement the other execute() primitives, + // because we're overriding Primitive's default dispatching below @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { final int length = args.length - 1; // Number of arguments. - if (length == 8) - { - return LispThread.currentThread().execute(args[0], args[1], - args[2], args[3], - args[4], args[5], - args[6], args[7], - args[8]); - } - else - { - LispObject[] newArgs = new LispObject[length]; - System.arraycopy(args, 1, newArgs, 0, length); - return LispThread.currentThread().execute(args[0], newArgs); - } + LispObject[] newArgs = new LispObject[length]; + System.arraycopy(args, 1, newArgs, 0, length); + return LispThread.currentThread().execute(args[0], newArgs); } }; @@ -2574,72 +2272,12 @@ new Primitive(Symbol.APPLY, "function &rest args") { @Override - public LispObject execute() throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - return error(new WrongNumberOfArgumentsException(this)); - } - @Override - public LispObject execute(LispObject fun, LispObject args) - throws ConditionThrowable - { - final LispThread thread = LispThread.currentThread(); - final int length = args.length(); - switch (length) - { - case 0: - return thread.execute(fun); - case 1: - return thread.execute(fun, ((Cons)args).car); - case 2: - { - Cons cons = (Cons) args; - return thread.execute(fun, cons.car, ((Cons)cons.cdr).car); - } - case 3: - return thread.execute(fun, args.car(), args.cadr(), - args.cdr().cdr().car()); - default: - { - final LispObject[] funArgs = new LispObject[length]; - int j = 0; - while (args != NIL) - { - funArgs[j++] = args.car(); - args = args.cdr(); - } - return funcall(fun, funArgs, thread); - } - } - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - if (third.listp()) - { - final int numFunArgs = 1 + third.length(); - final LispObject[] funArgs = new LispObject[numFunArgs]; - funArgs[0] = second; - int j = 1; - while (third != NIL) - { - funArgs[j++] = third.car(); - third = third.cdr(); - } - return funcall(first, funArgs, LispThread.currentThread()); - } - return type_error(third, Symbol.LIST); - } - @Override public LispObject execute(final LispObject[] args) throws ConditionThrowable { final int numArgs = args.length; + if (numArgs < 2) + return error(new WrongNumberOfArgumentsException(this)); + LispObject spread = args[numArgs - 1]; if (spread.listp()) { @@ -2677,7 +2315,7 @@ cons = (Cons) list; else return type_error(list, Symbol.LIST); - LispObject obj = thread.execute(fun, cons.car); + LispObject obj = thread.execute(fun, new LispObject[] { cons.car }); if (splice == null) { splice = new Cons(obj, result); @@ -2705,7 +2343,7 @@ while (list1 != NIL && list2 != NIL) { LispObject obj = - thread.execute(fun, list1.car(), list2.car()); + thread.execute(fun, new LispObject[] { list1.car(), list2.car() }); if (splice == null) { splice = new Cons(obj, result); @@ -2778,7 +2416,7 @@ cons = (Cons) list; else return type_error(list, Symbol.LIST); - thread.execute(fun, cons.car); + thread.execute(fun, new LispObject[] { cons.car }); list = cons.cdr; } thread._values = null; @@ -2793,7 +2431,7 @@ LispObject result = list1; while (list1 != NIL && list2 != NIL) { - thread.execute(fun, list1.car(), list2.car()); + thread.execute(fun, new LispObject[] { list1.car(), list2.car() }); list1 = ((Cons)list1).cdr; list2 = ((Cons)list2).cdr; } @@ -3423,7 +3061,7 @@ Symbol make_expander_for_macrolet = PACKAGE_SYS.intern("MAKE-EXPANDER-FOR-MACROLET"); LispObject expander = - make_expander_for_macrolet.execute(def); + make_expander_for_macrolet.execute(new LispObject[] { def }); Closure expansionFunction = new Closure(expander, env); MacroObject macroObject = new MacroObject(symbol, expansionFunction); @@ -4576,7 +4214,7 @@ while (tail instanceof Cons) { LispObject candidate = ((Cons)tail).car; - if (test.execute(item, candidate) != NIL) + if (test.execute(new LispObject[] { item, candidate }) != NIL) return tail; tail = ((Cons)tail).cdr; } @@ -4587,7 +4225,7 @@ while (tail instanceof Cons) { LispObject candidate = ((Cons)tail).car; - if (testNot.execute(item, candidate) == NIL) + if (testNot.execute(new LispObject[] { item, candidate }) == NIL) return tail; tail = ((Cons)tail).cdr; } @@ -4598,15 +4236,15 @@ // key != NIL while (tail instanceof Cons) { - LispObject candidate = key.execute(((Cons)tail).car); + LispObject candidate = key.execute(new LispObject[] { ((Cons)tail).car }); if (test != NIL) { - if (test.execute(item, candidate) != NIL) + if (test.execute(new LispObject[] { item, candidate }) != NIL) return tail; } else { - if (testNot.execute(item, candidate) == NIL) + if (testNot.execute(new LispObject[] { item, candidate }) == NIL) return tail; } tail = ((Cons)tail).cdr; @@ -4627,7 +4265,7 @@ throws ConditionThrowable { if (first != NIL) - return LispThread.currentThread().execute(first, second); + return LispThread.currentThread().execute(new LispObject[] { first, second }); return second; } }; Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Profiler.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Profiler.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Profiler.java Mon May 18 14:02:39 2009 @@ -92,7 +92,8 @@ object.setCallCount(0); if (object instanceof StandardGenericFunction) { LispObject methods = - PACKAGE_MOP.intern("GENERIC-FUNCTION-METHODS").execute(object); + PACKAGE_MOP.intern("GENERIC-FUNCTION-METHODS") + .execute(new LispObject[] { object }); while (methods != NIL) { StandardMethod method = (StandardMethod) methods.car(); method.getFunction().setCallCount(0); Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/ReaderMacroFunction.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/ReaderMacroFunction.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/ReaderMacroFunction.java Mon May 18 14:02:39 2009 @@ -62,11 +62,14 @@ } @Override - public LispObject execute(LispObject first, LispObject second) + public LispObject execute(LispObject[] args) throws ConditionThrowable { - Stream stream = inSynonymOf(first); - char c = LispCharacter.getValue(second); + if (args.length != 2) + return error(new WrongNumberOfArgumentsException(this)); + + Stream stream = inSynonymOf(args[0]); + char c = LispCharacter.getValue(args[1]); return execute(stream, c); } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/SimpleCondition.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/SimpleCondition.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/SimpleCondition.java Mon May 18 14:02:39 2009 @@ -87,7 +87,7 @@ @Override public LispObject execute(LispObject arg) throws ConditionThrowable { - return Symbol.STD_SLOT_VALUE.execute(arg, Symbol.FORMAT_CONTROL); + return Symbol.STD_SLOT_VALUE.execute(new LispObject[] { arg, Symbol.FORMAT_CONTROL }); } }; @@ -98,7 +98,7 @@ @Override public LispObject execute(LispObject arg) throws ConditionThrowable { - return Symbol.STD_SLOT_VALUE.execute(arg, Symbol.FORMAT_ARGUMENTS); + return Symbol.STD_SLOT_VALUE.execute(new LispObject[] { arg, Symbol.FORMAT_ARGUMENTS }); } }; } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/SlimeInputStream.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/SlimeInputStream.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/SlimeInputStream.java Mon May 18 14:02:39 2009 @@ -96,7 +96,8 @@ if (offset >= length) { try { ostream.finishOutput(); - s = LispThread.currentThread().execute(f).getStringValue(); + s = LispThread.currentThread() + .execute(f, new LispObject[0]).getStringValue(); } catch (Throwable t) { return -1; Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/SlimeOutputStream.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/SlimeOutputStream.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/SlimeOutputStream.java Mon May 18 14:02:39 2009 @@ -130,7 +130,7 @@ if (stringWriter.getBuffer().length() > 0) { String s = stringWriter.toString(); stringWriter.getBuffer().setLength(0); - LispThread.currentThread().execute(f, new SimpleString(s)); + LispThread.currentThread().execute(f, new LispObject[] { new SimpleString(s) }); } } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/SlotClass.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/SlotClass.java Mon May 18 14:02:39 2009 @@ -110,7 +110,7 @@ if (c instanceof StandardClass) { LispObject obj = ((StandardClass)c).getDirectDefaultInitargs(); if (obj != NIL) - result = Symbol.APPEND.execute(result, obj); + result = Symbol.APPEND.execute(new LispObject[] { result, obj }); } cpl = cpl.cdr(); } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/SpecialOperator.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/SpecialOperator.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/SpecialOperator.java Mon May 18 14:02:39 2009 @@ -68,26 +68,22 @@ } } - @Override public LispObject execute() throws ConditionThrowable { return error(new UndefinedFunction(getLambdaName())); } - @Override public LispObject execute(LispObject arg) throws ConditionThrowable { return error(new UndefinedFunction(getLambdaName())); } - @Override public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { return error(new UndefinedFunction(getLambdaName())); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable @@ -95,7 +91,6 @@ return error(new UndefinedFunction(getLambdaName())); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable @@ -103,7 +98,6 @@ return error(new UndefinedFunction(getLambdaName())); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) @@ -112,7 +106,6 @@ return error(new UndefinedFunction(getLambdaName())); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) @@ -121,7 +114,6 @@ return error(new UndefinedFunction(getLambdaName())); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, @@ -131,7 +123,6 @@ return error(new UndefinedFunction(getLambdaName())); } - @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, @@ -144,7 +135,32 @@ @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { - return error(new UndefinedFunction(getLambdaName())); + switch (args.length) + { + case 0: + return execute(); + case 1: + return execute(args[0]); + case 2: + return execute(args[0], args[1]); + case 3: + return execute(args[0], args[1], args[2]); + case 4: + return execute(args[0], args[1], args[2], args[3]); + case 5: + return execute(args[0], args[1], args[2], args[3], args[4]); + case 6: + return execute(args[0], args[1], args[2], args[3], args[4], + args[5]); + case 7: + return execute(args[0], args[1], args[2], args[3], args[4], + args[5], args[6]); + case 8: + return execute(args[0], args[1], args[2], args[3], args[4], + args[5], args[6], args[7]); + default: + return error(new UndefinedFunction(getLambdaName())); + } } @Override Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardClass.java Mon May 18 14:02:39 2009 @@ -73,11 +73,12 @@ Layout layout = getClassLayout(); if (layout == null) { - Symbol.ERROR.execute(Symbol.SIMPLE_ERROR, + Symbol.ERROR.execute( + new LispObject[] { Symbol.SIMPLE_ERROR, Keyword.FORMAT_CONTROL, new SimpleString("No layout for class ~S."), Keyword.FORMAT_ARGUMENTS, - list(this)); + list(this) }); } return new StandardObject(this, layout.getLength()); } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardGenericFunction.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Mon May 18 14:02:39 2009 @@ -125,83 +125,6 @@ } @Override - public LispObject execute() throws ConditionThrowable - { - return function.execute(); - } - - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - return function.execute(arg); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - return function.execute(first, second); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - return function.execute(first, second, third); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - return function.execute(first, second, third, fourth); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - return function.execute(first, second, third, fourth, - fifth); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - return function.execute(first, second, third, fourth, - fifth, sixth); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - return function.execute(first, second, third, fourth, - fifth, sixth, seventh); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - return function.execute(first, second, third, fourth, - fifth, sixth, seventh, eighth); - } - - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { return function.execute(args); Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardObject.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/StandardObject.java Mon May 18 14:02:39 2009 @@ -161,7 +161,7 @@ if (typep(Symbol.CONDITION) != NIL) { StringOutputStream stream = new StringOutputStream(); - Symbol.PRINT_OBJECT.execute(this, stream); + Symbol.PRINT_OBJECT.execute(new LispObject[] { this, stream }); return stream.getString().getStringValue(); } return unreadableString(typeOf().writeToString()); @@ -235,8 +235,8 @@ newInstance.layout = tempLayout; Debug.assertTrue(!layout.isInvalid()); // Call UPDATE-INSTANCE-FOR-REDEFINED-CLASS. - Symbol.UPDATE_INSTANCE_FOR_REDEFINED_CLASS.execute(this, added, - discarded, plist); + Symbol.UPDATE_INSTANCE_FOR_REDEFINED_CLASS + .execute(new LispObject[] { this, added, discarded, plist }); return newLayout; } @@ -373,8 +373,9 @@ if (value == UNBOUND_VALUE) { LispObject slotName = instance.layout.getSlotNames()[index]; - value = Symbol.SLOT_UNBOUND.execute(instance.getLispClass(), - instance, slotName); + value = Symbol.SLOT_UNBOUND + .execute(new LispObject[] { instance.getLispClass(), + instance, slotName }); LispThread.currentThread()._values = null; } return value; @@ -423,8 +424,9 @@ // Not found. final LispThread thread = LispThread.currentThread(); LispObject value = - thread.execute(Symbol.SLOT_MISSING, instance.getLispClass(), - instance, second, Symbol.SLOT_BOUNDP); + thread.execute(Symbol.SLOT_MISSING, + new LispObject[] { instance.getLispClass(), + instance, second, Symbol.SLOT_BOUNDP }); // "If SLOT-MISSING is invoked and returns a value, a boolean // equivalent to its primary value is returned by SLOT-BOUNDP." thread._values = null; @@ -452,13 +454,15 @@ // Check for shared slot. LispObject location = layout.getSharedSlotLocation(slotName); if (location == null) - return Symbol.SLOT_MISSING.execute(getLispClass(), this, slotName, - Symbol.SLOT_VALUE); + return Symbol.SLOT_MISSING + .execute(new LispObject[] { getLispClass(), this, slotName, + Symbol.SLOT_VALUE }); value = location.cdr(); } if (value == UNBOUND_VALUE) { - value = Symbol.SLOT_UNBOUND.execute(getLispClass(), this, slotName); + value = Symbol.SLOT_UNBOUND + .execute(new LispObject[] { getLispClass(), this, slotName }); LispThread.currentThread()._values = null; } return value; Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Stream.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Stream.java Mon May 18 14:02:39 2009 @@ -538,7 +538,7 @@ if (handler instanceof ReaderMacroFunction) return ((ReaderMacroFunction)handler).execute(this, c); if (handler != null && handler != NIL) - return handler.execute(this, LispCharacter.getInstance(c)); + return handler.execute(new LispObject[] { this, LispCharacter.getInstance(c) }); return readToken(c, rt); } @@ -596,7 +596,7 @@ Symbol DEFSTRUCT_DEFAULT_CONSTRUCTOR = PACKAGE_SYS.intern("DEFSTRUCT-DEFAULT-CONSTRUCTOR"); LispObject constructor = - DEFSTRUCT_DEFAULT_CONSTRUCTOR.getSymbolFunctionOrDie().execute(structure); + DEFSTRUCT_DEFAULT_CONSTRUCTOR.getSymbolFunctionOrDie().execute(new LispObject[] { structure }); final int length = args.length(); if ((length % 2) != 0) return error(new ReaderError("Odd number of keyword arguments following #S: " + @@ -644,7 +644,7 @@ Symbol DEFSTRUCT_DEFAULT_CONSTRUCTOR = PACKAGE_SYS.intern("DEFSTRUCT-DEFAULT-CONSTRUCTOR"); LispObject constructor = - DEFSTRUCT_DEFAULT_CONSTRUCTOR.getSymbolFunctionOrDie().execute(structure); + DEFSTRUCT_DEFAULT_CONSTRUCTOR.getSymbolFunctionOrDie().execute(new LispObject[] { structure }); final int length = args.length(); if ((length % 2) != 0) return error(new ReaderError("Odd number of keyword arguments following #S: " + @@ -792,8 +792,9 @@ if (fun != NIL) { LispObject result = - thread.execute(fun, this, LispCharacter.getInstance(c), - (numArg < 0) ? NIL : Fixnum.getInstance(numArg)); + thread.execute(fun, + new LispObject[] { this, LispCharacter.getInstance(c), + (numArg < 0) ? NIL : Fixnum.getInstance(numArg) }); LispObject[] values = thread._values; if (values != null && values.length == 0) result = null; Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/StructureObject.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/StructureObject.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/StructureObject.java Mon May 18 14:02:39 2009 @@ -403,7 +403,7 @@ Symbol PRINT_RESTART = PACKAGE_SYS.intern("PRINT-RESTART"); LispObject fun = PRINT_RESTART.getSymbolFunction(); StringOutputStream stream = new StringOutputStream(); - thread.execute(fun, this, stream); + thread.execute(fun, new LispObject[] { this, stream }); return stream.getString().getStringValue(); } if (_PRINT_STRUCTURE_.symbolValue(thread) == NIL) @@ -446,7 +446,7 @@ { StringOutputStream stream = new StringOutputStream(); thread.execute(Symbol.OUTPUT_OBJECT.getSymbolFunction(), - slots[i], stream); + new LispObject[] { slots[i], stream }); sb.append(stream.getString().getStringValue()); } else Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Symbol.java Mon May 18 14:02:39 2009 @@ -714,149 +714,6 @@ } @Override - public LispObject execute() throws ConditionThrowable - { - try - { - return function.execute(); - } - catch (NullPointerException e) - { - return handleNPE(e, NIL); - } - } - - @Override - public LispObject execute(LispObject arg) throws ConditionThrowable - { - try - { - return function.execute(arg); - } - catch (NullPointerException e) - { - return handleNPE(e, list(arg)); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second) - throws ConditionThrowable - { - try - { - return function.execute(first, second); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second)); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - throws ConditionThrowable - { - try - { - return function.execute(first, second, third); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second, third)); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - throws ConditionThrowable - { - try - { - return function.execute(first, second, third, fourth); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second, third, fourth)); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - throws ConditionThrowable - { - try - { - return function.execute(first, second, third, fourth, fifth); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second, third, fourth, fifth)); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - throws ConditionThrowable - { - try - { - return function.execute(first, second, third, fourth, fifth, sixth); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second, third, fourth, fifth, - sixth)); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - throws ConditionThrowable - { - try - { - return function.execute(first, second, third, fourth, fifth, sixth, - seventh); - } - catch (NullPointerException e) - { - return handleNPE(e, - list(first, second, third, fourth, fifth, sixth, - seventh)); - } - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - throws ConditionThrowable - { - try - { - return function.execute(first, second, third, fourth, fifth, sixth, - seventh, eighth); - } - catch (NullPointerException e) - { - return handleNPE(e, - list(first, second, third, fourth, fifth, sixth, - seventh, eighth)); - } - } - - @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { try @@ -877,7 +734,7 @@ { if (function == null) return LispThread.currentThread().execute(Symbol.UNDEFINED_FUNCTION_CALLED, - this, args); + new LispObject[] { this, args }); Debug.trace(e); return error(new LispError("Null pointer exception")); } Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/Time.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/Time.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/Time.java Mon May 18 14:02:39 2009 @@ -86,7 +86,7 @@ long realStart = System.currentTimeMillis(); try { - return arg.execute(); + return arg.execute(new LispObject[0]); } finally { Modified: branches/fewer-executes/abcl/src/org/armedbear/lisp/ZeroRankArray.java ============================================================================== --- branches/fewer-executes/abcl/src/org/armedbear/lisp/ZeroRankArray.java (original) +++ branches/fewer-executes/abcl/src/org/armedbear/lisp/ZeroRankArray.java Mon May 18 14:02:39 2009 @@ -148,7 +148,7 @@ if (data == this && Symbol.PRINT_CIRCLE.symbolValue(thread) != NIL) { StringOutputStream stream = new StringOutputStream(); thread.execute(Symbol.OUTPUT_OBJECT.getSymbolFunction(), - data, stream); + new LispObject[] { data, stream }); sb.append(stream.getString().getStringValue()); } else sb.append(data.writeToString()); From astalla at common-lisp.net Mon May 18 19:37:44 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 18 May 2009 15:37:44 -0400 Subject: [armedbear-cvs] r11894 - in trunk/abcl/src/org/armedbear/lisp/scripting: . lisp Message-ID: Author: astalla Date: Mon May 18 15:37:43 2009 New Revision: 11894 Log: Fixed function evaluation using invokeFunction. It was broken since last commit on JSR-223. Now invokeFunction uses the same "eval-in-script-context" macro that is used to evaluate interpreted and compiled code in the right environment, including special variables from the ScriptContext. In passing, the invokeFunction() method has also been fixed so that javaInstance() is called on its return value, like it happens in all other kinds of Lisp calls from Java. Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp trunk/abcl/src/org/armedbear/lisp/scripting/lisp/packages.lisp Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Mon May 18 15:37:43 2009 @@ -39,8 +39,21 @@ public class AbclScriptEngine extends AbstractScriptEngine implements Invocable, Compilable { private Interpreter interpreter; + /** + * The function used to evaluate a string of code. + */ private Function evalScript; + /** + * The function used to evaluate a Lisp function. + */ + private Function evalFunction; + /** + * The function used to compile Lisp code. + */ private Function compileScript; + /** + * The function used to evaluate a compiled script. + */ private Function evalCompiledScript; protected AbclScriptEngine() { @@ -61,6 +74,7 @@ evalScript = (Function) this.findSymbol("EVAL-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); compileScript = (Function) this.findSymbol("COMPILE-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); evalCompiledScript = (Function) this.findSymbol("EVAL-COMPILED-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); + evalFunction = (Function) this.findSymbol("EVAL-FUNCTION", "ABCL-SCRIPT").getSymbolFunction(); } catch (ConditionThrowable e) { throw new RuntimeException(e); } @@ -218,11 +232,6 @@ return Symbol.LIST.getSymbolFunction().execute(argList); } - @Override - public ScriptContext getContext() { - return super.getContext(); - } - private Object eval(Function evaluator, LispObject code, ScriptContext ctx) throws ScriptException { ReaderInputStream in = null; WriterOutputStream out = null; @@ -232,12 +241,11 @@ out = new WriterOutputStream(ctx.getWriter()); Stream outStream = new Stream(out, Symbol.CHARACTER); Stream inStream = new Stream(in, Symbol.CHARACTER); - retVal = evaluator.execute(makeBindings(ctx.getBindings(ScriptContext.GLOBAL_SCOPE)), makeBindings(ctx.getBindings(ScriptContext.ENGINE_SCOPE)), inStream, outStream, code, new JavaObject(ctx)); - return toJava(retVal); + return retVal.javaInstance(); } catch (ConditionThrowable e) { throw new ScriptException(new Exception(e)); } catch (IOException e) { @@ -274,10 +282,6 @@ public ScriptEngineFactory getFactory() { return new AbclScriptEngineFactory(); } - - private static Object toJava(LispObject lispObject) throws ConditionThrowable { - return lispObject.javaInstance(); - } public static LispObject toLisp(Object javaObject) { if(javaObject == null) { @@ -341,79 +345,59 @@ } } - @Override - public Object invokeFunction(String name, Object... args) throws ScriptException, NoSuchMethodException { - try { - Symbol s; - if(name.indexOf(':') >= 0) { - s = findSymbol(name); - } else { - s = findSymbol(name, "ABCL-SCRIPT-USER"); - } - if(s != null) { - LispObject f = s.getSymbolFunction(); - if(f != null && f instanceof Function) { - LispObject[] wrappedArgs = new LispObject[args.length]; - for(int i = 0; i < args.length; ++i) { - wrappedArgs[i] = toLisp(args[i]); - } - switch(args.length) { - case 0: - return LispThread.currentThread().execute(f); - case 1: - return LispThread.currentThread().execute(f, wrappedArgs[0]); - case 2: - return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1]); - case 3: - return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2]); - case 4: - return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3]); - case 5: - return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4]); - case 6: - return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5]); - case 7: - return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5], wrappedArgs[6]); - case 8: - return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5], wrappedArgs[6], wrappedArgs[7]); - default: - return LispThread.currentThread().execute(f, wrappedArgs); - } - } else { - throw new NoSuchMethodException(name); + @Override + public Object invokeFunction(String name, Object... args) throws ScriptException, NoSuchMethodException { + try { + Symbol s; + if(name.indexOf(':') >= 0) { + s = findSymbol(name); + } else { + s = findSymbol(name, "ABCL-SCRIPT-USER"); + } + if(s != null) { + LispObject f = s.getSymbolFunction(); + if(f != null && f instanceof Function) { + LispObject functionAndArgs = Lisp.NIL.push(f); + for(int i = 0; i < args.length; ++i) { + functionAndArgs = functionAndArgs.push(toLisp(args[i])); } + functionAndArgs = functionAndArgs.reverse(); + return eval(evalFunction, functionAndArgs, getContext()); } else { throw new NoSuchMethodException(name); } - } catch (ConditionThrowable e) { - throw new ScriptException(new RuntimeException(e)); + } else { + throw new NoSuchMethodException(name); } + } catch (ConditionThrowable e) { + throw new ScriptException(new RuntimeException(e)); } + } - @Override - public Object invokeMethod(Object thiz, String name, Object... args) throws ScriptException, NoSuchMethodException { - throw new UnsupportedOperationException("Common Lisp does not have methods in the Java sense."); - } - - public class AbclCompiledScript extends CompiledScript { - - private LispObject function; - - public AbclCompiledScript(LispObject function) { - this.function = function; - } - - @Override - public Object eval(ScriptContext context) throws ScriptException { - return AbclScriptEngine.this.eval(evalCompiledScript, function, context); - } + @Override + public Object invokeMethod(Object thiz, String name, Object... args) throws ScriptException, NoSuchMethodException { + throw new UnsupportedOperationException("Common Lisp does not have methods in the Java sense."); + } - @Override - public ScriptEngine getEngine() { - return AbclScriptEngine.this; - } + public class AbclCompiledScript extends CompiledScript { + private LispObject function; + + public AbclCompiledScript(LispObject function) { + this.function = function; } + + @Override + public Object eval(ScriptContext context) throws ScriptException { + return AbclScriptEngine.this.eval(evalCompiledScript, function, context); + } + + @Override + public ScriptEngine getEngine() { + return AbclScriptEngine.this; + } + + } @Override Modified: trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp Mon May 18 15:37:43 2009 @@ -92,6 +92,11 @@ ,actual-engine-bindings (jcall +get-bindings+ ,script-context +engine-scope+))))))))) +(defun eval-function (global-bindings engine-bindings stdin stdout function-and-args script-context) + (eval-in-script-context (global-bindings engine-bindings stdin stdout script-context) + `((funcall ,@(mapcar (lambda (arg) `(quote ,arg)) + function-and-args))))) + (defun eval-script (global-bindings engine-bindings stdin stdout code-string script-context) (eval-in-script-context (global-bindings engine-bindings stdin stdout script-context) Modified: trunk/abcl/src/org/armedbear/lisp/scripting/lisp/packages.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/lisp/packages.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/lisp/packages.lisp Mon May 18 15:37:43 2009 @@ -31,11 +31,12 @@ (defpackage :abcl-script (:use :cl :java) (:export - #:eval-script #:compile-script #:*compile-using-temp-files* #:configure-abcl #:eval-compiled-script + #:eval-function + #:eval-script #:define-java-interface-implementation #:find-java-interface-implementation #:*launch-swank-at-startup* From astalla at common-lisp.net Mon May 18 19:51:10 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 18 May 2009 15:51:10 -0400 Subject: [armedbear-cvs] r11895 - branches/jnlp Message-ID: Author: astalla Date: Mon May 18 15:51:09 2009 New Revision: 11895 Log: Branching from trunk at revision 11894 Added: branches/jnlp/ - copied from r11894, /trunk/ From ehuelsmann at common-lisp.net Mon May 18 20:28:03 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 18 May 2009 16:28:03 -0400 Subject: [armedbear-cvs] r11896 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 18 16:28:02 2009 New Revision: 11896 Log: Followup to r11892: use the field class too when caching, the caller assumes that specific class. Note to self: this definitely needs cleanup later. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon May 18 16:28:02 2009 @@ -2197,7 +2197,7 @@ loading the object value into a field upon class-creation time. The field type of the object is specified by OBJ-REF." - (let ((field-name (gethash1 obj *declared-objects*))) + (let ((field-name (gethash1 (list obj obj-ref) *declared-objects*))) (if field-name field-name (let ((key (symbol-name (gensym "OBJ")))) @@ -2213,7 +2213,7 @@ (emit 'checkcast obj-class)) (emit 'putstatic *this-class* g2 obj-ref) (setf *static-code* *code*) - (setf (gethash obj *declared-objects*) g2)))))) + (setf (gethash (list obj obj-ref) *declared-objects*) g2)))))) (defun declare-lambda (obj) (let* ((g (symbol-name (gensym "LAMBDA"))) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Mon May 18 16:28:02 2009 @@ -107,7 +107,7 @@ (integers (make-hash-table :test 'eql)) (floats (make-hash-table :test 'eql)) (doubles (make-hash-table :test 'eql)) - (objects (make-hash-table :test 'eq))) + (objects (make-hash-table :test 'equal))) (defun class-name-from-filespec (filespec) (let* ((name (pathname-name filespec))) From astalla at common-lisp.net Mon May 18 21:16:15 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 18 May 2009 17:16:15 -0400 Subject: [armedbear-cvs] r11897 - branches/jnlp/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon May 18 17:16:14 2009 New Revision: 11897 Log: Initial attempt at JNLP - Java Web Start. This currently needs full security permissions to run. Modified: branches/jnlp/abcl/src/org/armedbear/lisp/Interpreter.java branches/jnlp/abcl/src/org/armedbear/lisp/Lisp.java branches/jnlp/abcl/src/org/armedbear/lisp/Load.java Modified: branches/jnlp/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- branches/jnlp/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ branches/jnlp/abcl/src/org/armedbear/lisp/Interpreter.java Mon May 18 17:16:14 2009 @@ -39,6 +39,7 @@ import java.io.InputStream; import java.io.InputStreamReader; import java.io.OutputStream; +import java.security.*; public final class Interpreter extends Lisp { @@ -127,6 +128,15 @@ private Interpreter() { + + Policy.setPolicy + (new Policy() { + public PermissionCollection getPermissions(CodeSource codesource) { + Permissions perms = new Permissions(); + perms.add(new AllPermission()); + return (perms); + } + }); jlisp = false; inputStream = null; outputStream = null; Modified: branches/jnlp/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/jnlp/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ branches/jnlp/abcl/src/org/armedbear/lisp/Lisp.java Mon May 18 17:16:14 2009 @@ -1023,53 +1023,41 @@ coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue(thread)); } } - if (device instanceof Pathname) - { - // We're loading a fasl from j.jar. + if (device instanceof Pathname) { + // We're loading a fasl from a jar. URL url = Lisp.class.getResource(namestring); - if (url != null) - { - try - { - String s = url.toString(); - String zipFileName; - String entryName; - if (s.startsWith("jar:file:")) - { - s = s.substring(9); - int index = s.lastIndexOf('!'); - if (index >= 0) - { - zipFileName = s.substring(0, index); - entryName = s.substring(index + 1); - if (entryName.length() > 0 && entryName.charAt(0) == '/') - entryName = entryName.substring(1); - if (Utilities.isPlatformWindows) - { - // "/C:/Documents%20and%20Settings/peter/Desktop/j.jar" - if (zipFileName.length() > 0 && zipFileName.charAt(0) == '/') - zipFileName = zipFileName.substring(1); - } - zipFileName = URLDecoder.decode(zipFileName, "UTF-8"); - ZipFile zipFile = new ZipFile(zipFileName); - try - { - ZipEntry entry = zipFile.getEntry(entryName); - if (entry != null) - { - long size = entry.getSize(); - InputStream in = zipFile.getInputStream(entry); - LispObject obj = loadCompiledFunction(in, (int) size); - return obj != null ? obj : NIL; - } - } - finally - { - zipFile.close(); - } - } - } - } + if (url != null) { + try { + InputStream input = url.openStream(); + java.io.ByteArrayOutputStream baos = + new java.io.ByteArrayOutputStream(); + + byte[] bytes = new byte[4096]; + int n = 0; + while (n >= 0) { + n = input.read(bytes, 0, 4096); + if(n >= 0) { + baos.write(bytes, 0, n); + } + } + input.close(); + bytes = baos.toByteArray(); + baos.close(); + JavaClassLoader loader = new JavaClassLoader(); + Class c = + loader.loadClassFromByteArray(null, bytes, 0, bytes.length); + if (c != null) { + Class[] parameterTypes = new Class[0]; + Constructor constructor = + c.getConstructor(parameterTypes); + Object[] initargs = new Object[0]; + LispObject obj = + (LispObject) constructor.newInstance(initargs); + if (obj instanceof Function) + ((Function)obj).setClassBytes(bytes); + return obj != null ? obj : NIL; + } + } catch (VerifyError e) { return error(new LispError("Class verification failed: " + Modified: branches/jnlp/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- branches/jnlp/abcl/src/org/armedbear/lisp/Load.java (original) +++ branches/jnlp/abcl/src/org/armedbear/lisp/Load.java Mon May 18 17:16:14 2009 @@ -300,8 +300,10 @@ if (url != null) { try { in = url.openStream(); - if ("jar".equals(url.getProtocol())) + if ("jar".equals(url.getProtocol()) && + url.getPath().startsWith("file:")) { pathname = new Pathname(url); + } truename = getPath(url); } catch (IOException e) { From ehuelsmann at common-lisp.net Mon May 18 21:21:06 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 18 May 2009 17:21:06 -0400 Subject: [armedbear-cvs] r11898 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 18 17:21:02 2009 New Revision: 11898 Log: Revert r11892 and r11896 because they keep causing breakage in different places. We need general infrastructure for this problem. To come. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon May 18 17:21:02 2009 @@ -2197,23 +2197,20 @@ loading the object value into a field upon class-creation time. The field type of the object is specified by OBJ-REF." - (let ((field-name (gethash1 (list obj obj-ref) *declared-objects*))) - (if field-name - field-name - (let ((key (symbol-name (gensym "OBJ")))) - (remember key obj) - (let* ((g1 (declare-string key)) - (g2 (symbol-name (gensym "O2BJ"))) - (*code* *static-code*)) - (declare-field g2 obj-ref) - (emit 'getstatic *this-class* g1 +lisp-simple-string+) - (emit-invokestatic +lisp-class+ "recall" - (list +lisp-simple-string+) +lisp-object+) - (when (and obj-class (string/= obj-class +lisp-object-class+)) - (emit 'checkcast obj-class)) - (emit 'putstatic *this-class* g2 obj-ref) - (setf *static-code* *code*) - (setf (gethash (list obj obj-ref) *declared-objects*) g2)))))) + (let ((key (symbol-name (gensym "OBJ")))) + (remember key obj) + (let* ((g1 (declare-string key)) + (g2 (symbol-name (gensym "O2BJ")))) + (let* ((*code* *static-code*)) + (declare-field g2 obj-ref) + (emit 'getstatic *this-class* g1 +lisp-simple-string+) + (emit-invokestatic +lisp-class+ "recall" + (list +lisp-simple-string+) +lisp-object+) + (when (and obj-class (string/= obj-class +lisp-object-class+)) + (emit 'checkcast obj-class)) + (emit 'putstatic *this-class* g2 obj-ref) + (setf *static-code* *code*) + g2)))) (defun declare-lambda (obj) (let* ((g (symbol-name (gensym "LAMBDA"))) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Mon May 18 17:21:02 2009 @@ -87,7 +87,6 @@ (defvar *declared-integers* nil) (defvar *declared-floats* nil) (defvar *declared-doubles* nil) -(defvar *declared-objects* nil) (defstruct (class-file (:constructor %make-class-file)) pathname ; pathname of output file @@ -106,8 +105,7 @@ (strings (make-hash-table :test 'eq)) (integers (make-hash-table :test 'eql)) (floats (make-hash-table :test 'eql)) - (doubles (make-hash-table :test 'eql)) - (objects (make-hash-table :test 'equal))) + (doubles (make-hash-table :test 'eql))) (defun class-name-from-filespec (filespec) (let* ((name (pathname-name filespec))) @@ -139,8 +137,7 @@ (*declared-strings* (class-file-strings ,var)) (*declared-integers* (class-file-integers ,var)) (*declared-floats* (class-file-floats ,var)) - (*declared-doubles* (class-file-doubles ,var)) - (*declared-objects* (class-file-objects ,var))) + (*declared-doubles* (class-file-doubles ,var))) (progn , at body) (setf (class-file-pool ,var) *pool* (class-file-pool-count ,var) *pool-count* @@ -152,8 +149,7 @@ (class-file-strings ,var) *declared-strings* (class-file-integers ,var) *declared-integers* (class-file-floats ,var) *declared-floats* - (class-file-doubles ,var) *declared-doubles* - (class-file-objects ,var) *declared-objects*)))) + (class-file-doubles ,var) *declared-doubles*)))) (defstruct compiland name From ehuelsmann at common-lisp.net Tue May 19 19:50:34 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 19 May 2009 15:50:34 -0400 Subject: [armedbear-cvs] r11899 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 19 15:50:30 2009 New Revision: 11899 Log: Add structure slot and variable documentation. 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 Tue May 19 15:50:30 2009 @@ -208,16 +208,22 @@ (defvar *handlers* ()) (defstruct handler - from - to - code - catch-type) + from ;; label indicating the start of the protected block + to ;; label indicating the end of the protected block + code ;; label to jump to if the specified exception occurs + catch-type ;; pool index of the class name of the exception, or 0 (zero) + ;; for 'all' + ) ;; Variables visible at the current point of compilation. -(defvar *visible-variables* nil) +(defvar *visible-variables* nil + "All variables visible to the form currently being +processed, including free specials.") ;; All variables seen so far. -(defvar *all-variables* nil) +(defvar *all-variables* nil + "All variables in the lexical scope (thus excluding free specials) +of the compilands being processed (p1: so far; p2: in total).") ;; Undefined variables that we've already warned about. (defvar *undefined-variables* nil) From ehuelsmann at common-lisp.net Tue May 19 19:52:17 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 19 May 2009 15:52:17 -0400 Subject: [armedbear-cvs] r11900 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 19 15:52:15 2009 New Revision: 11900 Log: Add comment to *in-jvm-compile* variable. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Tue May 19 15:52:15 2009 @@ -341,6 +341,18 @@ (in-package "PRECOMPILER") +;; No source-transforms and inlining in precompile-function-call +;; No macro expansion in precompile-dolist and precompile-dotimes +;; No macro expansion in precompile-do/do* +;; No macro expansion in precompile-defun +;; Special precompilation in precompile-case and precompile-cond +;; Special precompilation in precompile-when and precompile-unless +;; No precompilation in precompile-nth-value +;; Special precompilation in precompile-return +;; Special precompilation in expand-macro +;; +;; if *in-jvm-compile* is false + (defvar *in-jvm-compile* nil) (defvar *local-variables* nil) From ehuelsmann at common-lisp.net Wed May 20 20:17:35 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 16:17:35 -0400 Subject: [armedbear-cvs] r11901 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 16:17:30 2009 New Revision: 11901 Log: In an effort to understand what's going on: Consolidate GET-LAMBDA-TO-COMPILE, %JVM-COMPILE, JVM-COMPILE and JVM-COMPILE-PACKAGE. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed May 20 16:17:30 2009 @@ -8350,79 +8350,70 @@ (format *error-output* "; ~S~%" name)))) (terpri *error-output*)))))) -(defun get-lambda-to-compile (thing) - (if (and (consp thing) - (eq (%car thing) 'LAMBDA)) - thing - (multiple-value-bind (lambda-expression environment) - (function-lambda-expression (if (typep thing 'standard-generic-function) - (mop::funcallable-instance-function thing) - thing)) - (unless lambda-expression - (error "Can't find a definition for ~S." thing)) - (values lambda-expression environment)))) +(defun %jvm-compile (name definition expr env) + (let* (compiled-function + (tempfile (make-temp-file))) + (with-compilation-unit () + (with-saved-compiler-policy + (unwind-protect + (setf compiled-function + (load-compiled-function + (compile-defun name expr env tempfile)))) + (delete-file tempfile))) + (when (and name (functionp compiled-function)) + (sys::%set-lambda-name compiled-function name) + (sys:set-call-count compiled-function (sys:call-count definition)) + (sys::%set-arglist compiled-function (sys::arglist definition)) + (let ((*warn-on-redefinition* nil)) + (cond ((typep definition 'standard-generic-function) + (mop:set-funcallable-instance-function definition compiled-function)) + (t + (setf (fdefinition name) + (if (macro-function name) + (make-macro name compiled-function) + compiled-function)))))) + (or name compiled-function))) -(defun %jvm-compile (name definition) +(defun jvm-compile (name &optional definition) (unless definition - (resolve name) + (resolve name) ;; Make sure the symbol has been resolved by the autoloader (setf definition (fdefinition name))) (when (compiled-function-p definition) - (return-from %jvm-compile (values name nil nil))) - (multiple-value-bind (expr env) - (get-lambda-to-compile definition) - (let* ((*package* (if (and name (symbol-package name)) - (symbol-package name) - *package*)) - compiled-function - (warnings-p nil) - (failure-p nil)) - (with-compilation-unit () - (with-saved-compiler-policy - (let* ((tempfile (make-temp-file))) - (unwind-protect - (setf compiled-function - (load-compiled-function - (handler-bind ((style-warning - #'(lambda (c) - (declare (ignore c)) - (setf warnings-p t) - nil)) - ((or warning - compiler-error) - #'(lambda (c) - (declare (ignore c)) - (setf warnings-p t - failure-p t) - nil))) - (compile-defun name expr env tempfile)))) - (delete-file tempfile)))) - (when (and name (functionp compiled-function)) - (sys::%set-lambda-name compiled-function name) - (sys:set-call-count compiled-function (sys:call-count definition)) - (sys::%set-arglist compiled-function (sys::arglist definition)) - (let ((*warn-on-redefinition* nil)) - (cond ((typep definition 'standard-generic-function) - (mop:set-funcallable-instance-function definition compiled-function)) - (t - (setf (fdefinition name) - (if (macro-function name) - (make-macro name compiled-function) - compiled-function))))))) - (values (or name compiled-function) warnings-p failure-p)))) - -(defun jvm-compile (name &optional definition) - (if *catch-errors* - (handler-case - (%jvm-compile name definition) - (compiler-unsupported-feature-error - (c) - (fresh-line) - (sys::%format t "; UNSUPPORTED FEATURE: ~A~%" c) - (if name - (sys::%format t "; Unable to compile ~S.~%" name) - (sys::%format t "; Unable to compile top-level form.~%")) - (precompiler::precompile name definition))) - (%jvm-compile name definition))) + (return-from jvm-compile (values name nil nil))) + (let ((catch-errors *catch-errors*) + (warnings-p nil) + (failure-p nil) + (*package* (or (and name (symbol-package name)) *package*)) + (expression definition) + environment) + (unless (and (consp definition) (eq (car definition) 'LAMBDA)) + (when (typep definition 'standard-generic-function) + (setf definition (mop::funcallable-instance-function definition))) + (multiple-value-setq + (expression environment) + (function-lambda-expression definition))) + (unless expression + (error "Can't find a definition for ~S." definition)) + (handler-bind + ((compiler-unsupported-feature-error + #'(lambda (c) + (when catch-errors + (fresh-line) + (sys::%format t "; UNSUPPORTED FEATURE: ~A~%" c) + (sys::%format t "; Unable to compile ~S.~%" + (or name "top-level form")) + (precompiler::precompile name definition) + t))) + (style-warning + #'(lambda (c) (declare (ignore c)) + (setf warnings-p t) nil)) + ((or warning compiler-error) + #'(lambda (c) (declare (ignore c)) + (setf warnings-p t + failure-p t) + nil))) + (values (%jvm-compile name definition expression environment) + warnings-p failure-p)))) (defun jvm-compile-package (package-designator) (let ((pkg (if (packagep package-designator) @@ -8431,11 +8422,7 @@ (dolist (sym (sys::package-symbols pkg)) (when (fboundp sym) (unless (or (special-operator-p sym) (macro-function sym)) - ;; Force autoload to be resolved. - (resolve sym) - (let ((f (fdefinition sym))) - (unless (compiled-function-p f) - (jvm-compile sym))))))) + (jvm-compile sym))))) t) (defun initialize-p2-handlers () From ehuelsmann at common-lisp.net Wed May 20 20:20:38 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 16:20:38 -0400 Subject: [armedbear-cvs] r11902 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 16:20:36 2009 New Revision: 11902 Log: Add documentation for a variable. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed May 20 16:20:36 2009 @@ -355,7 +355,9 @@ (defvar *in-jvm-compile* nil) -(defvar *local-variables* nil) +(defvar *local-variables* nil + "An alist with all local variables visible in the context +of the form being preprocessed.") (declaim (ftype (function (t) t) find-varspec)) (defun find-varspec (sym) From ehuelsmann at common-lisp.net Wed May 20 20:50:28 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 16:50:28 -0400 Subject: [armedbear-cvs] r11903 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 16:50:27 2009 New Revision: 11903 Log: Factor out common function definition replacement from PRE::PRECOMPILE and JVM::%JVM-COMPILE. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed May 20 16:50:27 2009 @@ -8350,6 +8350,17 @@ (format *error-output* "; ~S~%" name)))) (terpri *error-output*)))))) +(defun set-function-definition (name new old) + (let ((*warn-on-redefinition* nil)) + (sys::%set-lambda-name new name) + (sys:set-call-count new (sys:call-count old)) + (sys::%set-arglist new (sys::arglist old)) + (when (macro-function name) + (setf new (make-macro name new))) + (if (typep old 'standard-generic-function) + (mop:set-funcallable-instance-function old new) + (setf (fdefinition name) new)))) + (defun %jvm-compile (name definition expr env) (let* (compiled-function (tempfile (make-temp-file))) @@ -8361,17 +8372,7 @@ (compile-defun name expr env tempfile)))) (delete-file tempfile))) (when (and name (functionp compiled-function)) - (sys::%set-lambda-name compiled-function name) - (sys:set-call-count compiled-function (sys:call-count definition)) - (sys::%set-arglist compiled-function (sys::arglist definition)) - (let ((*warn-on-redefinition* nil)) - (cond ((typep definition 'standard-generic-function) - (mop:set-funcallable-instance-function definition compiled-function)) - (t - (setf (fdefinition name) - (if (macro-function name) - (make-macro name compiled-function) - compiled-function)))))) + (set-function-definition name compiled-function definition)) (or name compiled-function))) (defun jvm-compile (name &optional definition) Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed May 20 16:50:27 2009 @@ -1043,16 +1043,7 @@ (return-from precompile (values nil t t)))) (setf result (coerce-to-function (precompile-form expr nil))) (when (and name (functionp result)) - (%set-lambda-name result name) - (set-call-count result (call-count definition)) - (let ((*warn-on-redefinition* nil)) - (if (and (symbolp name) (macro-function name)) - (let ((mac (make-macro name result))) - (%set-arglist mac (arglist (symbol-function name))) - (setf (fdefinition name) mac)) - (progn - (setf (fdefinition name) result) - (%set-arglist result (arglist definition)))))) + (sys::set-function-definition name result definition)) (values (or name result) nil nil))) (defun precompile-package (pkg &key verbose) From ehuelsmann at common-lisp.net Wed May 20 20:54:04 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 16:54:04 -0400 Subject: [armedbear-cvs] r11904 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 16:54:04 2009 New Revision: 11904 Log: Followup to r11901: better mirror the old behaviour. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed May 20 16:54:04 2009 @@ -8403,8 +8403,8 @@ (sys::%format t "; UNSUPPORTED FEATURE: ~A~%" c) (sys::%format t "; Unable to compile ~S.~%" (or name "top-level form")) - (precompiler::precompile name definition) - t))) + (return-from jvm-compile + (precompiler::precompile name definition)))) (style-warning #'(lambda (c) (declare (ignore c)) (setf warnings-p t) nil)) From ehuelsmann at common-lisp.net Wed May 20 21:12:51 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 17:12:51 -0400 Subject: [armedbear-cvs] r11905 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 17:12:49 2009 New Revision: 11905 Log: Move COMPILE from jvm.lisp to compiler-pass2.lisp; Move SET-FUNCTION-DEFINITION helper from compiler-pass2.lisp to precompiler.lisp; Add a closing paren forgotten in r11904. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed May 20 17:12:49 2009 @@ -8350,16 +8350,6 @@ (format *error-output* "; ~S~%" name)))) (terpri *error-output*)))))) -(defun set-function-definition (name new old) - (let ((*warn-on-redefinition* nil)) - (sys::%set-lambda-name new name) - (sys:set-call-count new (sys:call-count old)) - (sys::%set-arglist new (sys::arglist old)) - (when (macro-function name) - (setf new (make-macro name new))) - (if (typep old 'standard-generic-function) - (mop:set-funcallable-instance-function old new) - (setf (fdefinition name) new)))) (defun %jvm-compile (name definition expr env) (let* (compiled-function @@ -8375,6 +8365,18 @@ (set-function-definition name compiled-function definition)) (or name compiled-function))) + +(defvar *file-compilation* nil) +(defvar *pathnames-generator* #'make-temp-file) + +(defun compile (name &optional definition) + (jvm-compile name definition)) + +(defmacro with-file-compilation (&body body) + `(let ((*file-compilation* t) + (*pathnames-generator* #'sys::next-classfile-name)) + , at body)) + (defun jvm-compile (name &optional definition) (unless definition (resolve name) ;; Make sure the symbol has been resolved by the autoloader @@ -8386,6 +8388,10 @@ (failure-p nil) (*package* (or (and name (symbol-package name)) *package*)) (expression definition) + (*file-compilation* nil) + (*visible-variables* nil) + (*pathnames-generator* #'make-temp-file) + (sys::*fasl-anonymous-package* (sys::%make-package)) environment) (unless (and (consp definition) (eq (car definition) 'LAMBDA)) (when (typep definition 'standard-generic-function) @@ -8404,7 +8410,7 @@ (sys::%format t "; Unable to compile ~S.~%" (or name "top-level form")) (return-from jvm-compile - (precompiler::precompile name definition)))) + (precompiler::precompile name definition))))) (style-warning #'(lambda (c) (declare (ignore c)) (setf warnings-p t) nil)) 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 May 20 17:12:49 2009 @@ -481,20 +481,6 @@ (t (setf (variable-ignorable-p variable) t)))))))) -(defvar *file-compilation* nil) -(defvar *pathnames-generator* #'make-temp-file) - -(defun compile (name &optional definition) - (let ((*file-compilation* nil) - (*pathnames-generator* #'make-temp-file) - (sys::*fasl-anonymous-package* (sys::%make-package))) - (jvm-compile name definition))) - -(defmacro with-file-compilation (&body body) - `(let ((*file-compilation* t) - (*pathnames-generator* #'sys::next-classfile-name)) - , at body)) - (defun finalize-generic-functions () (dolist (sym '(make-instance initialize-instance Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Wed May 20 17:12:49 2009 @@ -1019,6 +1019,17 @@ (eval (cadr binding))) bindings) (macroexpand-all `(progn , at forms) env)))) +(defun set-function-definition (name new old) + (let ((*warn-on-redefinition* nil)) + (sys::%set-lambda-name new name) + (sys:set-call-count new (sys:call-count old)) + (sys::%set-arglist new (sys::arglist old)) + (when (macro-function name) + (setf new (make-macro name new))) + (if (typep old 'standard-generic-function) + (mop:set-funcallable-instance-function old new) + (setf (fdefinition name) new)))) + (defun precompile (name &optional definition) (unless definition (setq definition (or (and (symbolp name) (macro-function name)) From ehuelsmann at common-lisp.net Wed May 20 22:18:51 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 18:18:51 -0400 Subject: [armedbear-cvs] r11906 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 18:18:49 2009 New Revision: 11906 Log: Remove rt.lisp: It refers to lots of files from the ANSI tests which we don't have in our tree anyway. Removed: trunk/abcl/src/org/armedbear/lisp/rt.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed May 20 18:18:49 2009 @@ -231,7 +231,6 @@ "restart.lisp" "revappend.lisp" "rotatef.lisp" - "rt.lisp" ;;"run-benchmarks.lisp" "run-shell-command.lisp" ;;"runtime-class.lisp" From ehuelsmann at common-lisp.net Wed May 20 22:20:45 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 18:20:45 -0400 Subject: [armedbear-cvs] r11907 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 18:20:42 2009 New Revision: 11907 Log: Move the COMPILE block down from its dependencies. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed May 20 18:20:42 2009 @@ -8362,21 +8362,10 @@ (compile-defun name expr env tempfile)))) (delete-file tempfile))) (when (and name (functionp compiled-function)) - (set-function-definition name compiled-function definition)) + (sys::set-function-definition name compiled-function definition)) (or name compiled-function))) -(defvar *file-compilation* nil) -(defvar *pathnames-generator* #'make-temp-file) - -(defun compile (name &optional definition) - (jvm-compile name definition)) - -(defmacro with-file-compilation (&body body) - `(let ((*file-compilation* t) - (*pathnames-generator* #'sys::next-classfile-name)) - , at body)) - (defun jvm-compile (name &optional definition) (unless definition (resolve name) ;; Make sure the symbol has been resolved by the autoloader @@ -8422,6 +8411,19 @@ (values (%jvm-compile name definition expression environment) warnings-p failure-p)))) +(defvar *file-compilation* nil) +(defvar *pathnames-generator* #'make-temp-file) + +(defun compile (name &optional definition) + (jvm-compile name definition)) + +(defmacro with-file-compilation (&body body) + `(let ((*file-compilation* t) + (*pathnames-generator* #'sys::next-classfile-name)) + , at body)) + + + (defun jvm-compile-package (package-designator) (let ((pkg (if (packagep package-designator) package-designator From ehuelsmann at common-lisp.net Wed May 20 22:22:36 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 18:22:36 -0400 Subject: [armedbear-cvs] r11908 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 18:22:33 2009 New Revision: 11908 Log: COMPILE has moved from "jvm" to "compiler-pass2". Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Wed May 20 18:22:33 2009 @@ -174,7 +174,7 @@ (autoload 'dribble) (autoload-macro 'step) (autoload 'load) -(autoload 'compile "jvm") +(autoload '(compile with-file-compilation) "compiler-pass2") (autoload-macro 'with-compilation-unit "jvm") (autoload-macro '(case ccase ecase typecase ctypecase etypecase) "case") @@ -308,5 +308,5 @@ ;; JVM compiler. (in-package "JVM") -(export '(jvm-compile jvm-compile-package)) +(export '(jvm-compile-package)) (autoload '%with-compilation-unit "jvm") From ehuelsmann at common-lisp.net Wed May 20 22:23:04 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 18:23:04 -0400 Subject: [armedbear-cvs] r11909 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 18:23:03 2009 New Revision: 11909 Log: No longer make JVM-COMPILE appear as an external symbol. 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 Wed May 20 18:23:03 2009 @@ -31,7 +31,7 @@ (in-package "JVM") -(export '(compile-defun *catch-errors* jvm-compile jvm-compile-package +(export '(compile-defun *catch-errors* jvm-compile-package derive-compiler-type)) (eval-when (:compile-toplevel :load-toplevel :execute) From ehuelsmann at common-lisp.net Wed May 20 22:48:32 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 18:48:32 -0400 Subject: [armedbear-cvs] r11910 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 18:48:31 2009 New Revision: 11910 Log: In JVM-COMPILE, don't setf the DEFINITION which breaks its use further down. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed May 20 18:48:31 2009 @@ -8383,11 +8383,12 @@ (sys::*fasl-anonymous-package* (sys::%make-package)) environment) (unless (and (consp definition) (eq (car definition) 'LAMBDA)) - (when (typep definition 'standard-generic-function) - (setf definition (mop::funcallable-instance-function definition))) - (multiple-value-setq - (expression environment) - (function-lambda-expression definition))) + (let ((function definition)) + (when (typep definition 'standard-generic-function) + (setf function (mop::funcallable-instance-function function))) + (multiple-value-setq + (expression environment) + (function-lambda-expression function)))) (unless expression (error "Can't find a definition for ~S." definition)) (handler-bind @@ -8408,7 +8409,7 @@ (setf warnings-p t failure-p t) nil))) - (values (%jvm-compile name definition expression environment) + (values (%jvm-compile name org-definition expression environment) warnings-p failure-p)))) (defvar *file-compilation* nil) From ehuelsmann at common-lisp.net Wed May 20 22:50:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 20 May 2009 18:50:02 -0400 Subject: [armedbear-cvs] r11911 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 20 18:49:56 2009 New Revision: 11911 Log: Followup to last commit. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed May 20 18:49:56 2009 @@ -8409,7 +8409,7 @@ (setf warnings-p t failure-p t) nil))) - (values (%jvm-compile name org-definition expression environment) + (values (%jvm-compile name definition expression environment) warnings-p failure-p)))) (defvar *file-compilation* nil) From ehuelsmann at common-lisp.net Thu May 21 10:20:01 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 06:20:01 -0400 Subject: [armedbear-cvs] r11912 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 06:19:53 2009 New Revision: 11912 Log: Remove unused variable *LOCAL-FUNCTIONS-AND-MACROS*. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu May 21 06:19:53 2009 @@ -612,8 +612,6 @@ (precompile1 (expand-macro form)) form)) -(defvar *local-functions-and-macros* ()) - (defun precompile-macrolet (form) (let ((*compile-file-environment* (make-environment *compile-file-environment*))) @@ -928,8 +926,7 @@ (declaim (ftype (function (t t) t) precompile-form)) (defun precompile-form (form in-jvm-compile) (let ((*in-jvm-compile* in-jvm-compile) - (*inline-declarations* *inline-declarations*) - (*local-functions-and-macros* ())) + (*inline-declarations* *inline-declarations*)) (precompile1 form))) (defun install-handler (symbol &optional handler) From ehuelsmann at common-lisp.net Thu May 21 11:22:34 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 07:22:34 -0400 Subject: [armedbear-cvs] r11913 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 07:22:31 2009 New Revision: 11913 Log: Make sure the precompiler shadows symbol macros if there are MULTIPLE-VALUE-BIND bound variables by the same name. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu May 21 07:22:31 2009 @@ -855,7 +855,10 @@ (defun precompile-multiple-value-bind (form) (let ((vars (cadr form)) (values-form (caddr form)) - (body (cdddr form))) + (body (cdddr form)) + (*local-variables* *local-variables*)) + (dolist (var vars) + (push (list var :variable) *local-variables*)) (list* 'MULTIPLE-VALUE-BIND vars (precompile1 values-form) From ehuelsmann at common-lisp.net Thu May 21 14:05:31 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 10:05:31 -0400 Subject: [armedbear-cvs] r11914 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 10:05:29 2009 New Revision: 11914 Log: Remove trailing spaces. Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Environment.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Environment.java Thu May 21 10:05:29 2009 @@ -301,7 +301,7 @@ return first; } }; - + // ### empty-environment-p private static final Primitive EMPTY_ENVIRONMENT_P = new Primitive("empty-environment-p", PACKAGE_SYS, true, "environment") From ehuelsmann at common-lisp.net Thu May 21 17:14:43 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 13:14:43 -0400 Subject: [armedbear-cvs] r11915 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 13:14:40 2009 New Revision: 11915 Log: Reuse available infrastructure in Environment, instead of keeping track of locals (and their shadowing effect) ourselves. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu May 21 13:14:40 2009 @@ -256,7 +256,7 @@ (eq (%car callee) 'function) (symbolp (cadr callee)) (not (special-operator-p (cadr callee))) - (not (macro-function (cadr callee) sys:*compile-file-environment*)) + (not (macro-function (cadr callee) *compile-file-environment*)) (memq (symbol-package (cadr callee)) (list (find-package "CL") (find-package "SYS")))) `(,(cadr callee) ,@(cdr args)) @@ -355,29 +355,15 @@ (defvar *in-jvm-compile* nil) -(defvar *local-variables* nil - "An alist with all local variables visible in the context -of the form being preprocessed.") - -(declaim (ftype (function (t) t) find-varspec)) -(defun find-varspec (sym) - (dolist (varspec *local-variables*) - (when (eq sym (car varspec)) - (return varspec)))) - (declaim (ftype (function (t) t) precompile1)) (defun precompile1 (form) (cond ((symbolp form) - (let ((varspec (find-varspec form))) - (cond ((and varspec (eq (second varspec) :symbol-macro)) - (precompile1 (copy-tree (third varspec)))) - ((null varspec) - (let ((expansion (expand-macro form))) - (if (eq expansion form) - form - (precompile1 expansion)))) - (t - form)))) + (multiple-value-bind + (expansion expanded) + (expand-macro form) + (if expanded + (precompile1 expansion) + form))) ((atom form) form) (t @@ -517,9 +503,12 @@ (cddr form))) (precompile1 (expand-macro form))) ((symbolp place) - (let ((varspec (find-varspec place))) - (if (and varspec (eq (second varspec) :symbol-macro)) - (precompile1 (list* 'SETF (copy-tree (third varspec)) (cddr form))) + (multiple-value-bind + (expansion expanded) + (expand-macro place) + (if expanded + (precompile1 (list* 'SETF expansion + (cddr form))) (precompile1 (expand-macro form))))) (t (precompile1 (expand-macro form)))))) @@ -532,11 +521,14 @@ :format-control "Odd number of arguments to SETQ.")) (if (= len 2) (let* ((sym (%car args)) - (val (%cadr args)) - (varspec (find-varspec sym))) - (if (and varspec (eq (second varspec) :symbol-macro)) - (precompile1 (list 'SETF (copy-tree (third varspec)) val)) - (list 'SETQ sym (precompile1 val)))) + (val (%cadr args))) + (multiple-value-bind + (expansion expanded) + (expand-macro sym) + (if expanded + (precompile1 (list 'SETF expansion val)) + (list 'SETQ sym (precompile1 val)) + ))) (let ((result ())) (loop (when (null args) @@ -628,8 +620,7 @@ `(locally , at decls ,@(mapcar #'precompile1 body))))) (defun precompile-symbol-macrolet (form) - (let ((*local-variables* *local-variables*) - (*compile-file-environment* + (let ((*compile-file-environment* (make-environment *compile-file-environment*)) (defs (cadr form))) (dolist (def defs) @@ -639,7 +630,6 @@ (error 'program-error :format-control "Attempt to bind the special variable ~S with SYMBOL-MACROLET." :format-arguments (list sym))) - (push (list sym :symbol-macro expansion) *local-variables*) (environment-add-symbol-binding *compile-file-environment* sym (sys::make-symbol-macro expansion)) @@ -688,14 +678,18 @@ :format-control "The variable ~S is not a symbol." :format-arguments (list v))) (push (list v (precompile1 expr)) result) - (push (list v :variable) *local-variables*))) + (environment-add-symbol-binding *compile-file-environment* + v nil))) ;; any value will do (t (push var result) - (push (list var :variable) *local-variables*)))) + (environment-add-symbol-binding *compile-file-environment* + var nil) +))) (nreverse result))) (defun precompile-let (form) - (let ((*local-variables* *local-variables*)) + (let ((*compile-file-environment* + (make-environment *compile-file-environment*))) (list* 'LET (precompile-let/let*-vars (cadr form)) (mapcar #'precompile1 (cddr form))))) @@ -712,7 +706,8 @@ (defun precompile-let* (form) (setf form (maybe-fold-let* form)) - (let ((*local-variables* *local-variables*)) + (let ((*compile-file-environment* + (make-environment *compile-file-environment*))) (list* 'LET* (precompile-let/let*-vars (cadr form)) (mapcar #'precompile1 (cddr form))))) @@ -856,9 +851,11 @@ (let ((vars (cadr form)) (values-form (caddr form)) (body (cdddr form)) - (*local-variables* *local-variables*)) + (*compile-file-environment* + (make-environment *compile-file-environment*)) +) (dolist (var vars) - (push (list var :variable) *local-variables*)) + (environment-add-symbol-binding *compile-file-environment* var nil)) (list* 'MULTIPLE-VALUE-BIND vars (precompile1 values-form) @@ -914,17 +911,19 @@ ;; is false and a macro is encountered that is also implemented as a special ;; operator, so interpreted code can use the special operator implementation. (defun expand-macro (form) - (loop - (unless *in-jvm-compile* - (when (and (consp form) - (symbolp (%car form)) - (special-operator-p (%car form))) - (return-from expand-macro form))) - (multiple-value-bind (result expanded) - (macroexpand-1 form *compile-file-environment*) - (unless expanded - (return-from expand-macro result)) - (setf form result)))) + (let (exp) + (loop + (unless *in-jvm-compile* + (when (and (consp form) + (symbolp (%car form)) + (special-operator-p (%car form))) + (return-from expand-macro form))) + (multiple-value-bind (result expanded) + (macroexpand-1 form *compile-file-environment*) + (unless expanded + (return-from expand-macro (values result exp))) + (setf form result + exp t))))) (declaim (ftype (function (t t) t) precompile-form)) (defun precompile-form (form in-jvm-compile) From ehuelsmann at common-lisp.net Thu May 21 17:22:32 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 13:22:32 -0400 Subject: [armedbear-cvs] r11916 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 13:22:31 2009 New Revision: 11916 Log: Indenting adjustments. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu May 21 13:22:31 2009 @@ -628,12 +628,12 @@ (expansion (cadr def))) (when (special-variable-p sym) (error 'program-error - :format-control "Attempt to bind the special variable ~S with SYMBOL-MACROLET." + :format-control + "Attempt to bind the special variable ~S with SYMBOL-MACROLET." :format-arguments (list sym))) (environment-add-symbol-binding *compile-file-environment* sym - (sys::make-symbol-macro expansion)) - )) + (sys::make-symbol-macro expansion)))) (multiple-value-bind (body decls) (parse-body (cddr form) nil) (when decls @@ -648,7 +648,8 @@ (dolist (special specials) (when (memq special syms) (error 'program-error - :format-control "~S is a symbol-macro and may not be declared special." + :format-control + "~S is a symbol-macro and may not be declared special." :format-arguments (list special)))))))) `(locally , at decls ,@(mapcar #'precompile1 body))))) @@ -683,8 +684,7 @@ (t (push var result) (environment-add-symbol-binding *compile-file-environment* - var nil) -))) + var nil)))) (nreverse result))) (defun precompile-let (form) @@ -791,7 +791,8 @@ (setf used-p t) (return)))))))) (unless used-p - (format t "; Note: deleting unused local function ~A ~S~%" operator name) + (format t "; Note: deleting unused local function ~A ~S~%" + operator name) (let* ((new-locals (remove local locals :test 'eq)) (new-form (if new-locals @@ -852,8 +853,7 @@ (values-form (caddr form)) (body (cdddr form)) (*compile-file-environment* - (make-environment *compile-file-environment*)) -) + (make-environment *compile-file-environment*))) (dolist (var vars) (environment-add-symbol-binding *compile-file-environment* var nil)) (list* 'MULTIPLE-VALUE-BIND @@ -934,7 +934,8 @@ (defun install-handler (symbol &optional handler) (declare (type symbol symbol)) (let ((handler (or handler - (find-symbol (sys::%format nil "PRECOMPILE-~A" (symbol-name symbol)) + (find-symbol (sys::%format nil "PRECOMPILE-~A" + (symbol-name symbol)) 'precompiler)))) (unless (and handler (fboundp handler)) (error "No handler for ~S." symbol)) @@ -992,7 +993,6 @@ (LOAD-TIME-VALUE precompile-load-time-value) (DECLARE precompile-identity) -;; (DEFMETHOD precompile-identity) (DEFUN precompile-defun) (GO precompile-identity) (QUOTE precompile-identity) From ehuelsmann at common-lisp.net Thu May 21 17:52:20 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 13:52:20 -0400 Subject: [armedbear-cvs] r11917 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 13:52:18 2009 New Revision: 11917 Log: In compiler macro FUNCALL: When in need of an environment, get it through the lambda list instead of hard coding a reference. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu May 21 13:52:18 2009 @@ -249,14 +249,15 @@ `(%subtypep , at args) form)) -(define-compiler-macro funcall (&whole form &rest args) +(define-compiler-macro funcall (&whole form + &environment env &rest args) (let ((callee (car args))) (if (and (>= *speed* *debug*) (consp callee) (eq (%car callee) 'function) (symbolp (cadr callee)) (not (special-operator-p (cadr callee))) - (not (macro-function (cadr callee) *compile-file-environment*)) + (not (macro-function (cadr callee) env)) (memq (symbol-package (cadr callee)) (list (find-package "CL") (find-package "SYS")))) `(,(cadr callee) ,@(cdr args)) From ehuelsmann at common-lisp.net Thu May 21 19:43:12 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 15:43:12 -0400 Subject: [armedbear-cvs] r11918 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 15:43:09 2009 New Revision: 11918 Log: With my improved understanding of the autoloader, mark COMPILE with "jvm". Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu May 21 15:43:09 2009 @@ -174,7 +174,7 @@ (autoload 'dribble) (autoload-macro 'step) (autoload 'load) -(autoload '(compile with-file-compilation) "compiler-pass2") +(autoload '(compile with-file-compilation) "jvm") (autoload-macro 'with-compilation-unit "jvm") (autoload-macro '(case ccase ecase typecase ctypecase etypecase) "case") From ehuelsmann at common-lisp.net Thu May 21 20:25:18 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 16:25:18 -0400 Subject: [armedbear-cvs] r11919 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 16:25:17 2009 New Revision: 11919 Log: Separate the precompiler and the file compiler by giving each its own 'current environment' variable: introduce *PRECOMPILE-ENV* in precompiler.lisp. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Thu May 21 16:25:17 2009 @@ -110,7 +110,7 @@ (return-from process-toplevel-form)) ((IN-PACKAGE DEFPACKAGE) (note-toplevel-form form) - (setf form (precompile-form form nil)) + (setf form (precompiler:precompile-form form nil *compile-file-environment*)) (eval form) ;; Force package prefix to be used when dumping form. (let ((*package* +keyword-package+)) @@ -162,7 +162,9 @@ ;; FIXME Should be a warning or error of some sort... (format *error-output* "; Unable to compile function ~A~%" name) - (let ((precompiled-function (precompile-form expr nil))) + (let ((precompiled-function + (precompiler:precompile-form expr nil + *compile-file-environment*))) (setf form `(fset ',name ,precompiled-function @@ -264,23 +266,24 @@ (return-from process-toplevel-form)) (cond ((eq operator 'QUOTE) -;;; (setf form (precompile-form form nil)) +;;; (setf form (precompiler:precompile-form form nil +;;; *compile-file-environment*)) (when compile-time-too (eval form)) (return-from process-toplevel-form)) ((eq operator 'PUT) - (setf form (precompile-form form nil))) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) ((eq operator 'COMPILER-DEFSTRUCT) - (setf form (precompile-form form nil))) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) ((eq operator 'PROCLAIM) - (setf form (precompile-form form nil))) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) (or (keywordp (second form)) (and (listp (second form)) (eq (first (second form)) 'QUOTE)))) - (setf form (precompile-form form nil))) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) ((eq operator 'IMPORT) - (setf form (precompile-form form nil)) + (setf form (precompiler:precompile-form form nil *compile-file-environment*)) ;; Make sure package prefix is printed when symbols are imported. (let ((*package* +keyword-package+)) (dump-form form stream)) @@ -293,22 +296,22 @@ (consp (third form)) (eq (%car (third form)) 'FUNCTION) (symbolp (cadr (third form)))) - (setf form (precompile-form form nil))) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) ;;; ((memq operator '(LET LET*)) ;;; (let ((body (cddr form))) ;;; (if (dolist (subform body nil) ;;; (when (and (consp subform) (eq (%car subform) 'DEFUN)) ;;; (return t))) ;;; (setf form (convert-toplevel-form form)) -;;; (setf form (precompile-form form nil))))) +;;; (setf form (precompiler:precompile-form form nil))))) ((eq operator 'mop::ensure-method) (setf form (convert-ensure-method form))) ((and (symbolp operator) (not (special-operator-p operator)) (null (cdr form))) - (setf form (precompile-form form nil))) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) (t -;;; (setf form (precompile-form form nil)) +;;; (setf form (precompiler:precompile-form form nil)) (note-toplevel-form form) (setf form (convert-toplevel-form form))))))))) (when (consp form) @@ -326,7 +329,7 @@ (defun convert-ensure-method (form) (c-e-m-1 form :function) (c-e-m-1 form :fast-function) - (precompile-form form nil)) + (precompiler:precompile-form form nil *compile-file-environment*)) (declaim (ftype (function (t t) t) c-e-m-1)) (defun c-e-m-1 (form key) @@ -356,7 +359,7 @@ (setf form (if compiled-function `(funcall (load-compiled-function ,(file-namestring classfile))) - (precompile-form form nil))))) + (precompiler:precompile-form form nil *compile-file-environment*))))) (defun process-toplevel-macrolet (form stream compile-time-too) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu May 21 16:25:17 2009 @@ -53,7 +53,7 @@ (t (setf body (copy-tree body)) (list 'LAMBDA lambda-list - (precompile-form (list* 'BLOCK block-name body) t))))) + (precompiler:precompile-form (list* 'BLOCK block-name body) t *compile-file-environment*))))) ) ; EVAL-WHEN ;;; Pass 1. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 21 16:25:17 2009 @@ -7328,7 +7328,8 @@ (defknown p2-setq (t t t) t) (defun p2-setq (form target representation) (unless (= (length form) 3) - (return-from p2-setq (compile-form (precompiler::precompile-setq form) + (return-from p2-setq (compile-form (precompiler:precompile-form form t + *compile-file-environment*) target representation))) (let ((expansion (macroexpand (%cadr form) *compile-file-environment*))) (unless (eq expansion (%cadr form)) @@ -8259,7 +8260,9 @@ :lambda-name ',name :lambda-list (cadr ',form))))))) (compile-1 (make-compiland :name name - :lambda-expression (precompile-form form t) + :lambda-expression + (precompiler:precompile-form form t + *compile-file-environment*) :class-file class-file))))) (defvar *catch-errors* t) @@ -8400,7 +8403,7 @@ (sys::%format t "; Unable to compile ~S.~%" (or name "top-level form")) (return-from jvm-compile - (precompiler::precompile name definition))))) + (sys:precompile name definition))))) (style-warning #'(lambda (c) (declare (ignore c)) (setf warnings-p t) nil)) Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu May 21 16:25:17 2009 @@ -333,8 +333,6 @@ (in-package "EXTENSIONS") -(export '(precompile-form precompile)) - (unless (find-package "PRECOMPILER") (make-package "PRECOMPILER" :nicknames '("PRE") @@ -355,6 +353,8 @@ ;; if *in-jvm-compile* is false (defvar *in-jvm-compile* nil) +(defvar *precompile-env* nil) + (declaim (ftype (function (t) t) precompile1)) (defun precompile1 (form) @@ -373,7 +373,7 @@ (when (symbolp op) (cond ((setf handler (get op 'precompile-handler)) (return-from precompile1 (funcall handler form))) - ((macro-function op *compile-file-environment*) + ((macro-function op *precompile-env*) (return-from precompile1 (precompile1 (expand-macro form)))) ((special-operator-p op) (error "PRECOMPILE1: unsupported special operator ~S." op)))) @@ -422,13 +422,13 @@ (defun precompile-dolist (form) (if *in-jvm-compile* - (precompile1 (macroexpand form *compile-file-environment*)) + (precompile1 (macroexpand form *precompile-env*)) (cons 'DOLIST (cons (mapcar #'precompile1 (cadr form)) (mapcar #'precompile1 (cddr form)))))) (defun precompile-dotimes (form) (if *in-jvm-compile* - (precompile1 (macroexpand form *compile-file-environment*)) + (precompile1 (macroexpand form *precompile-env*)) (cons 'DOTIMES (cons (mapcar #'precompile1 (cadr form)) (mapcar #'precompile1 (cddr form)))))) @@ -464,7 +464,7 @@ (defun precompile-do/do* (form) (if *in-jvm-compile* - (precompile1 (macroexpand form *compile-file-environment*)) + (precompile1 (macroexpand form *precompile-env*)) (list* (car form) (precompile-do/do*-vars (cadr form)) (precompile-do/do*-end-form (caddr form)) @@ -606,11 +606,10 @@ form)) (defun precompile-macrolet (form) - (let ((*compile-file-environment* - (make-environment *compile-file-environment*))) + (let ((*precompile-env* (make-environment *precompile-env*))) (dolist (definition (cadr form)) (environment-add-macro-definition - *compile-file-environment* + *precompile-env* (car definition) (make-macro (car definition) (make-closure @@ -621,8 +620,7 @@ `(locally , at decls ,@(mapcar #'precompile1 body))))) (defun precompile-symbol-macrolet (form) - (let ((*compile-file-environment* - (make-environment *compile-file-environment*)) + (let ((*precompile-env* (make-environment *precompile-env*)) (defs (cadr form))) (dolist (def defs) (let ((sym (car def)) @@ -632,7 +630,7 @@ :format-control "Attempt to bind the special variable ~S with SYMBOL-MACROLET." :format-arguments (list sym))) - (environment-add-symbol-binding *compile-file-environment* + (environment-add-symbol-binding *precompile-env* sym (sys::make-symbol-macro expansion)))) (multiple-value-bind (body decls) @@ -680,17 +678,15 @@ :format-control "The variable ~S is not a symbol." :format-arguments (list v))) (push (list v (precompile1 expr)) result) - (environment-add-symbol-binding *compile-file-environment* - v nil))) ;; any value will do + (environment-add-symbol-binding *precompile-env* v nil))) + ;; any value will do: we just need to shadow any symbol macros (t (push var result) - (environment-add-symbol-binding *compile-file-environment* - var nil)))) + (environment-add-symbol-binding *precompile-env* var nil)))) (nreverse result))) (defun precompile-let (form) - (let ((*compile-file-environment* - (make-environment *compile-file-environment*))) + (let ((*precompile-env* (make-environment *precompile-env*))) (list* 'LET (precompile-let/let*-vars (cadr form)) (mapcar #'precompile1 (cddr form))))) @@ -707,15 +703,14 @@ (defun precompile-let* (form) (setf form (maybe-fold-let* form)) - (let ((*compile-file-environment* - (make-environment *compile-file-environment*))) + (let ((*precompile-env* (make-environment *precompile-env*))) (list* 'LET* (precompile-let/let*-vars (cadr form)) (mapcar #'precompile1 (cddr form))))) (defun precompile-case (form) (if *in-jvm-compile* - (precompile1 (macroexpand form *compile-file-environment*)) + (precompile1 (macroexpand form *precompile-env*)) (let* ((keyform (cadr form)) (clauses (cddr form)) (result (list (precompile1 keyform)))) @@ -730,7 +725,7 @@ (defun precompile-cond (form) (if *in-jvm-compile* - (precompile1 (macroexpand form *compile-file-environment*)) + (precompile1 (macroexpand form *precompile-env*)) (let ((clauses (cdr form)) (result nil)) (dolist (clause clauses) @@ -746,7 +741,7 @@ (let ((name (car def)) (body (cddr def))) ;; Macro names are shadowed by local functions. - (environment-add-function-definition *compile-file-environment* name body) + (environment-add-function-definition *precompile-env* name body) (cdr (precompile-named-lambda (list* 'NAMED-LAMBDA def))))) (defun precompile-local-functions (defs) @@ -766,8 +761,7 @@ (find-use name (%cdr expression)))))) (defun precompile-flet/labels (form) - (let ((*compile-file-environment* - (make-environment *compile-file-environment*)) + (let ((*precompile-env* (make-environment *precompile-env*)) (operator (car form)) (locals (cadr form)) (body (cddr form))) @@ -840,12 +834,12 @@ (defun precompile-when (form) (if *in-jvm-compile* - (precompile1 (macroexpand form *compile-file-environment*)) + (precompile1 (macroexpand form *precompile-env*)) (precompile-cons form))) (defun precompile-unless (form) (if *in-jvm-compile* - (precompile1 (macroexpand form *compile-file-environment*)) + (precompile1 (macroexpand form *precompile-env*)) (precompile-cons form))) ;; MULTIPLE-VALUE-BIND is handled explicitly by the JVM compiler. @@ -853,10 +847,9 @@ (let ((vars (cadr form)) (values-form (caddr form)) (body (cdddr form)) - (*compile-file-environment* - (make-environment *compile-file-environment*))) + (*precompile-env* (make-environment *precompile-env*))) (dolist (var vars) - (environment-add-symbol-binding *compile-file-environment* var nil)) + (environment-add-symbol-binding *precompile-env* var nil)) (list* 'MULTIPLE-VALUE-BIND vars (precompile1 values-form) @@ -868,12 +861,12 @@ (defun precompile-nth-value (form) (if *in-jvm-compile* - (precompile1 (macroexpand form *compile-file-environment*)) + (precompile1 (macroexpand form *precompile-env*)) form)) (defun precompile-return (form) (if *in-jvm-compile* - (precompile1 (macroexpand form *compile-file-environment*)) + (precompile1 (macroexpand form *precompile-env*)) (list 'RETURN (precompile1 (cadr form))))) (defun precompile-return-from (form) @@ -920,16 +913,18 @@ (special-operator-p (%car form))) (return-from expand-macro form))) (multiple-value-bind (result expanded) - (macroexpand-1 form *compile-file-environment*) + (macroexpand-1 form *precompile-env*) (unless expanded (return-from expand-macro (values result exp))) (setf form result exp t))))) (declaim (ftype (function (t t) t) precompile-form)) -(defun precompile-form (form in-jvm-compile) +(defun precompile-form (form in-jvm-compile + &optional precompile-env) (let ((*in-jvm-compile* in-jvm-compile) - (*inline-declarations* *inline-declarations*)) + (*inline-declarations* *inline-declarations*) + (pre::*precompile-env* precompile-env)) (precompile1 form))) (defun install-handler (symbol &optional handler) @@ -1004,11 +999,12 @@ (install-handlers) +(export '(precompile-form)) + (in-package #:system) (defun macroexpand-all (form &optional env) - (let ((*compile-file-environment* env)) - (precompile-form form nil))) + (precompiler:precompile-form form nil env)) (defmacro compiler-let (bindings &body forms &environment env) (let ((bindings (mapcar #'(lambda (binding) @@ -1034,7 +1030,8 @@ (unless definition (setq definition (or (and (symbolp name) (macro-function name)) (fdefinition name)))) - (let (expr result) + (let (expr result + (pre::*precompile-env* nil)) (cond ((functionp definition) (multiple-value-bind (form closure-p) (function-lambda-expression definition) @@ -1052,7 +1049,7 @@ ;; (error 'type-error))) (format t "Unable to precompile ~S.~%" name) (return-from precompile (values nil t t)))) - (setf result (coerce-to-function (precompile-form expr nil))) + (setf result (coerce-to-function (precompiler:precompile-form expr nil))) (when (and name (functionp result)) (sys::set-function-definition name result definition)) (values (or name result) nil nil))) @@ -1131,8 +1128,12 @@ (when (and env (empty-environment-p env)) (setf env nil)) (when (null env) - (setf lambda-expression (precompile-form lambda-expression nil))) + (setf lambda-expression (precompiler:precompile-form lambda-expression nil))) `(progn (%defun ',name ,lambda-expression) ,@(when doc `((%set-documentation ',name 'function ,doc))))))))) + +(export '(precompile)) + +;;(provide "PRECOMPILER") \ No newline at end of file From ehuelsmann at common-lisp.net Thu May 21 21:16:31 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 17:16:31 -0400 Subject: [armedbear-cvs] r11920 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 17:16:30 2009 New Revision: 11920 Log: Enable precompilation of functions in a non-null lexical environment, now that the precompiler doesn't keep state outside the Environment anyway. Enables (amongst others): (symbol-macrolet ((b y)) (defun foo () (let (y) b))) (precompile 'foo) Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu May 21 17:16:30 2009 @@ -528,8 +528,7 @@ (expand-macro sym) (if expanded (precompile1 (list 'SETF expansion val)) - (list 'SETQ sym (precompile1 val)) - ))) + (list 'SETQ sym (precompile1 val))))) (let ((result ())) (loop (when (null args) @@ -1030,26 +1029,21 @@ (unless definition (setq definition (or (and (symbolp name) (macro-function name)) (fdefinition name)))) - (let (expr result + (let ((expr definition) + env result (pre::*precompile-env* nil)) - (cond ((functionp definition) - (multiple-value-bind (form closure-p) - (function-lambda-expression definition) - (unless form -;; (format t "; No lambda expression available for ~S.~%" name) - (return-from precompile (values nil t t))) - (when closure-p - (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name) - (finish-output) - (return-from precompile (values nil t t))) - (setq expr form))) - ((and (consp definition) (eq (%car definition) 'lambda)) - (setq expr definition)) - (t -;; (error 'type-error))) - (format t "Unable to precompile ~S.~%" name) - (return-from precompile (values nil t t)))) - (setf result (coerce-to-function (precompiler:precompile-form expr nil))) + (when (functionp definition) + (multiple-value-bind (form closure-p) + (function-lambda-expression definition) + (unless form + (return-from precompile (values nil t t))) + (setq env closure-p) + (setq expr form))) + (unless (and (consp expr) (eq (car expr) 'lambda)) + (format t "Unable to precompile ~S.~%" name) + (return-from precompile (values nil t t))) + (setf result + (sys:make-closure (precompiler:precompile-form expr nil env) env)) (when (and name (functionp result)) (sys::set-function-definition name result definition)) (values (or name result) nil nil))) From ehuelsmann at common-lisp.net Thu May 21 21:29:51 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 17:29:51 -0400 Subject: [armedbear-cvs] r11921 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 17:29:49 2009 New Revision: 11921 Log: COMPILE-DEFUN: pass the environment argument to pass the environment on to PRECOMPILE, instead of hardcoding *compile-file-environment*. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 21 17:29:49 2009 @@ -8262,7 +8262,7 @@ (compile-1 (make-compiland :name name :lambda-expression (precompiler:precompile-form form t - *compile-file-environment*) + environment) :class-file class-file))))) (defvar *catch-errors* t) From ehuelsmann at common-lisp.net Thu May 21 21:39:36 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 21 May 2009 17:39:36 -0400 Subject: [armedbear-cvs] r11922 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 21 17:39:34 2009 New Revision: 11922 Log: Simplify COMPILE-1. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 21 17:39:34 2009 @@ -8220,17 +8220,16 @@ ;; Pass 1. (p1-compiland compiland) (setf *closure-variables* - (remove-if-not #'variable-used-non-locally-p *all-variables*)) - (when *closure-variables* - (setf *closure-variables* - (remove-if #'variable-special-p *closure-variables*)) - (when *closure-variables* - (let ((i 0)) - (dolist (var (reverse *closure-variables*)) - (setf (variable-closure-index var) i) - (dformat t "var = ~S closure index = ~S~%" (variable-name var) - (variable-closure-index var)) - (incf i))))) + (remove-if #'variable-special-p + (remove-if-not #'variable-used-non-locally-p + *all-variables*))) + (let ((i 0)) + (dolist (var (reverse *closure-variables*)) + (setf (variable-closure-index var) i) + (dformat t "var = ~S closure index = ~S~%" (variable-name var) + (variable-closure-index var)) + (incf i))) + ;; Pass 2. (with-class-file (compiland-class-file compiland) (p2-compiland compiland) From ehuelsmann at common-lisp.net Fri May 22 05:51:37 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 22 May 2009 01:51:37 -0400 Subject: [armedbear-cvs] r11923 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 22 01:51:28 2009 New Revision: 11923 Log: Our input is already preprocessed. Don't do it again. (Eliminated in GENERATE-INLINE-EXPANSION). Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri May 22 01:51:28 2009 @@ -53,7 +53,7 @@ (t (setf body (copy-tree body)) (list 'LAMBDA lambda-list - (precompiler:precompile-form (list* 'BLOCK block-name body) t *compile-file-environment*))))) + (list* 'BLOCK block-name body))))) ) ; EVAL-WHEN ;;; Pass 1. From ehuelsmann at common-lisp.net Fri May 22 08:37:28 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 22 May 2009 04:37:28 -0400 Subject: [armedbear-cvs] r11924 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 22 04:37:09 2009 New Revision: 11924 Log: Implement compilation of closures with non-empty lexical environments (Part 1 [of 2]): Variables. Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Environment.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Environment.java Fri May 22 04:37:09 2009 @@ -328,4 +328,23 @@ return result.nreverse(); } }; + + // ### environment-all-variables + private static final Primitive ENVIRONMENT_ALL_VARS = + new Primitive("environment-all-variables", PACKAGE_SYS, true, "environment") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Environment env = checkEnvironment(arg); + LispObject result = NIL; + for (Binding binding = env.vars; + binding != null; binding = binding.next) + if (binding.specialp) + result = result.push(binding.symbol); + else + result = result.push(new Cons(binding.symbol, binding.value)); + return result.nreverse(); + } + }; } Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri May 22 04:37:09 2009 @@ -1798,6 +1798,16 @@ } }; + // ### symbol-macro-p + private static final Primitive SYMBOL_MACRO_P = + new Primitive("symbol-macro-p", PACKAGE_SYS, true, "value") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return (arg instanceof SymbolMacro) ? T : NIL; + } + }; // ### %defparameter private static final Primitive _DEFPARAMETER = 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 May 22 04:37:09 2009 @@ -236,6 +236,7 @@ (defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString") (defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;") (defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;") +(defconstant +lisp-environment-class+ "org/armedbear/lisp/Environment") (defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;") (defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw") (defconstant +lisp-return-class+ "org/armedbear/lisp/Return") @@ -4187,6 +4188,19 @@ (emit 'aaload) (emit-swap representation nil) (emit 'putfield +closure-binding-class+ "value" +lisp-object+)) + ((variable-environment variable) + (assert (not *file-compilation*)) + (emit 'getstatic *this-class* + (declare-object (variable-environment variable) + +lisp-environment+ + +lisp-environment-class+) + +lisp-environment+) + (emit 'swap) + (emit-push-variable-name variable) + (emit 'swap) + (emit-invokevirtual +lisp-environment-class+ "rebind" + (list +lisp-symbol+ +lisp-object+) + nil)) (t (assert nil)))))) @@ -4217,6 +4231,17 @@ (emit-push-constant-int (variable-closure-index variable)) (emit 'aaload) (emit 'getfield +closure-binding-class+ "value" +lisp-object+)) + ((variable-environment variable) + (assert (not *file-compilation*)) + (emit 'getstatic *this-class* + (declare-object (variable-environment variable) + +lisp-environment+ + +lisp-environment-class+) + +lisp-environment+) + (emit-push-variable-name variable) + (emit-invokevirtual +lisp-environment-class+ "lookup" + (list +lisp-object+) + +lisp-object+)) (t (assert nil))))) @@ -7293,7 +7318,8 @@ ((or (variable-representation variable) (variable-register variable) (variable-closure-index variable) - (variable-index variable)) + (variable-index variable) + (variable-environment variable)) (emit-push-variable variable) (convert-representation (variable-representation variable) representation) @@ -8230,6 +8256,13 @@ (variable-closure-index var)) (incf i))) + ;; Assert that we're not refering to any variables + ;; we're not allowed to use + (assert (= 0 + (length (remove-if (complement #'variable-references) + (remove-if #'variable-references-allowed-p + *visible-variables*))))) + ;; Pass 2. (with-class-file (compiland-class-file compiland) (p2-compiland compiland) @@ -8244,8 +8277,6 @@ (defun compile-defun (name form environment filespec) (aver (eq (car form) 'LAMBDA)) - (unless (or (null environment) (empty-environment-p environment)) - (compiler-unsupported "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment.")) (catch 'compile-defun-abort (let* ((class-file (make-class-file :pathname filespec :lambda-name name @@ -8257,7 +8288,8 @@ :class-file (make-class-file :pathname ,filespec :lambda-name ',name - :lambda-list (cadr ',form))))))) + :lambda-list (cadr ',form)))))) + (*compile-file-environment* environment)) (compile-1 (make-compiland :name name :lambda-expression (precompiler:precompile-form form t @@ -8393,6 +8425,19 @@ (function-lambda-expression function)))) (unless expression (error "Can't find a definition for ~S." definition)) + (when environment + (dolist (var (reverse (environment-all-variables environment))) + ;; We need to add all variables, even symbol macros, + ;; because the latter may shadow other variables by the same name + ;; The precompiler should have resolved all symbol-macros, so + ;; later we assert we didn't get any references to the symbol-macro. + (push (make-variable :name (if (symbolp var) var (car var)) + :special-p (symbolp var) + :environment environment + :references-allowed-p + (not (sys:symbol-macro-p (cdr var))) + :compiland NIL) *visible-variables*))) + ;; FIXME: we still need to add local functions, ofcourse. (handler-bind ((compiler-unsupported-feature-error #'(lambda (c) 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 May 22 04:37:09 2009 @@ -260,11 +260,15 @@ register ; register number for a local variable index ; index number for a variable in the argument array closure-index ; index number for a variable in the closure context array + environment ; the environment for the variable, if we're compiling in + ; a non-null lexical environment with variables ;; a variable can be either special-p *or* have a register *or* - ;; have an index *or a closure-index + ;; have an index *or* a closure-index *or* an environment (reads 0 :type fixnum) (writes 0 :type fixnum) references + (references-allowed-p t) ; NIL if this is a symbol macro in the enclosing + ; lexical environment used-non-locally-p (compiland *current-compiland*)) From ehuelsmann at common-lisp.net Fri May 22 10:06:41 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 22 May 2009 06:06:41 -0400 Subject: [armedbear-cvs] r11925 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 22 06:06:37 2009 New Revision: 11925 Log: Add reasoning related to variable-environment and the closure-array. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 22 06:06:37 2009 @@ -8245,10 +8245,14 @@ (with-saved-compiler-policy ;; Pass 1. (p1-compiland compiland) + + ;; *all-variables* doesn't contain variables which + ;; are in an enclosing lexical environment (variable-environment) + ;; so we don't need to filter them out (setf *closure-variables* (remove-if #'variable-special-p (remove-if-not #'variable-used-non-locally-p - *all-variables*))) + *all-variables*))) (let ((i 0)) (dolist (var (reverse *closure-variables*)) (setf (variable-closure-index var) i) From ehuelsmann at common-lisp.net Fri May 22 18:05:12 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 22 May 2009 14:05:12 -0400 Subject: [armedbear-cvs] r11926 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 22 14:04:53 2009 New Revision: 11926 Log: Compilation of functions with a non-null lexical environment part 2 [of 2]: Functions. Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Environment.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Environment.java Fri May 22 14:04:53 2009 @@ -347,4 +347,20 @@ return result.nreverse(); } }; + + // ### environment-all-functions + private static final Primitive ENVIRONMENT_ALL_FUNS = + new Primitive("environment-all-functions", PACKAGE_SYS, true, "environment") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Environment env = checkEnvironment(arg); + LispObject result = NIL; + for (FunctionBinding binding = env.lastFunctionBinding; + binding != null; binding = binding.next) + result = result.push(new Cons(binding.name, binding.value)); + return result.nreverse(); + } + }; } Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri May 22 14:04:53 2009 @@ -1787,6 +1787,18 @@ } }; + // ### macro-function-p + private static final Primitive MACRO_FUNCTION_P = + new Primitive("macro-function-p", PACKAGE_SYS, true, "value") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return (arg instanceof MacroObject) ? T : NIL; + } + }; + + // ### make-symbol-macro private static final Primitive MAKE_SYMBOL_MACRO = new Primitive("make-symbol-macro", PACKAGE_SYS, true, "expansion") 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 May 22 14:04:53 2009 @@ -3028,6 +3028,20 @@ (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)) + ((local-function-environment local-function) + (assert (local-function-references-allowed-p local-function)) + (assert (not *file-compilation*)) + (emit 'getstatic *this-class* + (declare-object (local-function-environment local-function) + +lisp-environment+ + +lisp-environment-class+) + +lisp-environment+) + (emit 'getstatic *this-class* + (declare-object (local-function-name local-function)) + +lisp-object+) + (emit-invokevirtual +lisp-environment-class+ "lookupFunction" + (list +lisp-object+) + +lisp-object+)) (t (dformat t "compile-local-function-call default case~%") (let* ((g (if *file-compilation* @@ -8240,7 +8254,7 @@ (let ((*all-variables* nil) (*closure-variables* nil) (*undefined-variables* nil) - (*local-functions* nil) + (*local-functions* *local-functions*) (*current-compiland* compiland)) (with-saved-compiler-policy ;; Pass 1. @@ -8417,6 +8431,7 @@ (expression definition) (*file-compilation* nil) (*visible-variables* nil) + (*local-functions* nil) (*pathnames-generator* #'make-temp-file) (sys::*fasl-anonymous-package* (sys::%make-package)) environment) @@ -8441,6 +8456,13 @@ :references-allowed-p (not (sys:symbol-macro-p (cdr var))) :compiland NIL) *visible-variables*))) + (when environment + (dolist (fun (reverse (environment-all-functions environment))) + (push (make-local-function :name (car fun) + :references-allowed-p + (not (macro-function-p (cdr fun))) + :environment environment) + *local-functions*))) ;; FIXME: we still need to add local functions, ofcourse. (handler-bind ((compiler-unsupported-feature-error 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 May 22 14:04:53 2009 @@ -337,10 +337,14 @@ name compiland inline-expansion - function ;; the function loaded through load-compiled-function - class-file - variable ;; the variable which contains the loaded compiled function - ;; or compiled closure + function ;; the function loaded through load-compiled-function + class-file ;; the class file structure for this function + variable ;; the variable which contains the loaded compiled function + ;; or compiled closure + environment ;; the environment in which the function is stored in + ;; case of a function from an enclosing lexical environment + ;; which itself isn't being compiled + (references-allowed-p t) ) (defvar *local-functions* ()) From ehuelsmann at common-lisp.net Fri May 22 18:17:12 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 22 May 2009 14:17:12 -0400 Subject: [armedbear-cvs] r11927 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 22 14:17:11 2009 New Revision: 11927 Log: Merge 2 consecutive WHEN blocks with the same condition; remove the FIXME comment which is now outdated. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 22 14:17:11 2009 @@ -8455,15 +8455,13 @@ :environment environment :references-allowed-p (not (sys:symbol-macro-p (cdr var))) - :compiland NIL) *visible-variables*))) - (when environment + :compiland NIL) *visible-variables*)) (dolist (fun (reverse (environment-all-functions environment))) (push (make-local-function :name (car fun) :references-allowed-p (not (macro-function-p (cdr fun))) :environment environment) *local-functions*))) - ;; FIXME: we still need to add local functions, ofcourse. (handler-bind ((compiler-unsupported-feature-error #'(lambda (c) From ehuelsmann at common-lisp.net Fri May 22 19:45:11 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 22 May 2009 15:45:11 -0400 Subject: [armedbear-cvs] r11928 - trunk/abcl Message-ID: Author: ehuelsmann Date: Fri May 22 15:45:11 2009 New Revision: 11928 Log: Update CHANGES with all work currently on trunk/. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Fri May 22 15:45:11 2009 @@ -1,3 +1,48 @@ +Version 0.15.0 +(?? Jun, 2009) - Anticipate a June date + + Summary of changes: + * Updated FASL version + * Support (pre)compilation of functions with a non-null lexical environment + * Compiler and precompiler cleanups + * 'rt.lisp' copy from ANSI test suite removed + * Many documentation additions for the (pre)compiler + * JSR-233 support improvements + * Refactoring of classes: + - deleted: CompiledFunction, ClosureTemplateFunction, CompiledClosure, + Primitive0R, Primitive1R, Primitive2R + - renamed: CompiledClosure [from ClosureTemplateFunction] + * Compiler support for non-constant &key and &optional initforms + * Fixed ticket #21: JVM stack inconsistency [due to use of RET/JSR] + * Numerous special bindings handling fixes, especially with respect + to (local) transfer of control with GO/RETURN-FROM + * Paths retrieved using URL.getPath() require decoding (r11815) + * Build doesn't work inside paths with spaces (r11813) + * Compilation of export of a symbol not in *package* (r11808) + * Moved compiler-related rewriting of forms from precompiler to compiler + * Removed chained closures ('XEPs') in case of &optional arguments only + * Loading of SLIME fails under specific conditions (r11791) + * Binding of *FASL-ANONYMOUS-PACKAGE* breaks specials handling (r11783) + * Fixed ANSI tests: DO-ALL-SYMBOLS.{6,9,12}, DEFINE-SETF-EXPANDER.{1,6,?}, + MULTIPLE-VALUE-SETQ.{5,8}, SYMBOL-MACROLET.8, COMPILE-FILE.{17,18} + * COMPILE and COMPILE-FILE second and third values after a failed + invocation inside the same compilation-unit (r11769) + * JCLASS on non-existing classes should signal an error (r11762) + * Dotted lambda lists break interpretation (r11760) + * Implementation of MACROEXPAND-ALL and COMPILER-LET (r11755) + * Switch from casting to 'instanceof' for performance (r11754) + * Google App Engine support: don't die if 'os.arch' isn't set (r11750) + * Excessive stack use while resolving #n= and #n# (r11474) + + +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 From ehuelsmann at common-lisp.net Fri May 22 20:18:29 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 22 May 2009 16:18:29 -0400 Subject: [armedbear-cvs] r11929 - public_html Message-ID: Author: ehuelsmann Date: Fri May 22 16:18:26 2009 New Revision: 11929 Log: Add properties. Modified: public_html/release-notes-0.13.shtml (contents, props changed) public_html/release-notes-0.14.shtml (contents, props changed) public_html/testimonials.shtml (props changed) Modified: public_html/release-notes-0.13.shtml ============================================================================== --- public_html/release-notes-0.13.shtml (original) +++ public_html/release-notes-0.13.shtml Fri May 22 16:18:26 2009 @@ -61,7 +61,7 @@
Valid XHTML 1.0 Strict
-
$Id: index.shtml 11358 2008-10-18 22:10:11Z ehuelsmann $
+
$Id$
Modified: public_html/release-notes-0.14.shtml ============================================================================== --- public_html/release-notes-0.14.shtml (original) +++ public_html/release-notes-0.14.shtml Fri May 22 16:18:26 2009 @@ -87,7 +87,7 @@
Valid XHTML 1.0 Strict
-
$Id: index.shtml 11358 2008-10-18 22:10:11Z ehuelsmann $
+
$Id$
From ehuelsmann at common-lisp.net Fri May 22 21:46:39 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 22 May 2009 17:46:39 -0400 Subject: [armedbear-cvs] r11930 - public_html/doc Message-ID: Author: ehuelsmann Date: Fri May 22 17:46:35 2009 New Revision: 11930 Log: Add documentation on the website as provided by Phil Berry (2009pb at googlemail). Added: public_html/doc/ public_html/doc/abcl-css.css public_html/doc/abcl-install-with-java.html public_html/doc/abcl-lisp-java-integration.html public_html/doc/abcl-start.html public_html/doc/ant-apache-org.jpg (contents, props changed) public_html/doc/getting-started.txt public_html/doc/javajdk.jpg (contents, props changed) public_html/doc/javajre.jpg (contents, props changed) Added: public_html/doc/abcl-css.css ============================================================================== --- (empty file) +++ public_html/doc/abcl-css.css Fri May 22 17:46:35 2009 @@ -0,0 +1,30 @@ +/* ---------------------------------------------------------------------------- + * File: abcl-css.css + * ------------------------------------------------------------------------- */ +pre { + background-color: rgb(153, 153, 221); + padding: 0.25em; + padding-left: 5em; +} + +/* ---------------------------------------------------------------------------- + * Push all the images right, and put padding around them. + * ------------------------------------------------------------------------- */ +.java-image { + float: right; + padding: 0.5em; +} + +/* ---------------------------------------------------------------------------- + * The welcome message at the top of each page. Just an idea -- to be removed + * (both this and the HTML) if not seen as suitable. + * ------------------------------------------------------------------------- */ +#welcome { + width: 25em; + margin: 0.5em; + padding-left: 10em; +} +#welcome pre { + padding: 0.5em; + color: white; +} Added: public_html/doc/abcl-install-with-java.html ============================================================================== --- (empty file) +++ public_html/doc/abcl-install-with-java.html Fri May 22 17:46:35 2009 @@ -0,0 +1,630 @@ + + + + +Installing armedbear the Java way + + + + + + + +

armedbear

+ +home + +
+
+C:\temp\abcl\abcl-src-0.12.0\dist>java -jar abcl.jar
+Armed Bear Common Lisp 0.12.0
+Java 1.6.0_05 Sun Microsystems Inc.
+Java HotSpot(TM) Client VM
+Low-level initialization completed in 1.262 seconds.
+Startup completed in 4.556 seconds.
+Type ":help" for a list of available commands.
+CL-USER(1): (list 'welcome 'to 'lisp!)
+(WELCOME TO LISP!)
+CL-USER(2):
+
+
+

Installing the Java way

+ +

+This page describes one way Java programmers can use to build an application. +In addition to the Java development kit, which is described below, this way +also uses a tool called Ant. Ant is a program familiar to Java developers. It +performs the same sort of tasks that make does for C programmers, ie it +provides a convenient means of managing the compilation and program building +tasks that a complex application requires. +

+

+Users of Java IDEs (Integrated Development Environment) such as +Eclipse or +NetBeans can build the ABCL JAR file +within these environments. If you are using these tools you will have already +downloaded the JDK, and these tools already have a version of Ant installed. +See the documentation for these tools if you wish to use these to build the +ABCL JAR file. +

+

+To install ABCL from the source code as described on this page you need: +

+
    +
  • the Java runtime system, which will probably already be installed + on your machine; +
    • +
  • the Java development kit, which + you have to download from Sun; +
    • +
  • and the Ant build tool for Java. +
    • +
+ +

+Once you have these pre-requisites sorted, you can then go ahead and +build ABCL. If you wish to use Linux there are +further steps to perform. +

+

The Java Runtime (JRE)

+ +

+ABCL needs at least Java 1.5. How do you know if you have this or not? Well, +for Windows users the quickest way to find out is to open a new command window +(click Start, then Run, type cmd and click OK). +At the command prompt type java -version. If you have the +Java.exe executable in your path you will see output similar to this: + +

+C:\>java -version 
+java version "1.6.0_11" 
+Java(TM) SE Runtime Environment (build 1.6.0_11-b03) 
+Java HotSpot(TM) Client VM (build 11.0-b16, mixed mode, sharing) 
+
+ +

+This will work because it is a version later than Java 1.5. However, if you get +this response: +

+
+'java' is not recognized as an internal or external command, 
+operable program or batch file. 
+
+

+It means one of two things, either you don't have Java installed, or if you do +it is not on your path. To check which one it is type: +

+ +
+dir /s c:\java.exe 
+
+

+This command may take a long time to run, as it is doing a search of your hard +drive, which may be large and have many files. (Of course you can, if you +prefer, use the Windows search tool: Start -- Search.) A typical +response may be: +

+
+C:\>dir /s \java.exe 
+Volume in drive C is Windows 
+Volume Serial Number is 7DDF-ABBD 
+        
+ Directory of C:\Program Files\Java\jre1.5.0_13\bin
+
+25/09/2007  19:26            49,248 java.exe
+               1 File(s)         49,248 bytes
+
+ Directory of C:\Program Files\Java\jre1.6.0_03\bin
+
+24/09/2007  21:30           135,168 java.exe
+               1 File(s)        135,168 bytes
+
+ Directory of C:\Program Files\Java\jre1.6.0_05\bin
+
+22/02/2008  00:23           135,168 java.exe
+               1 File(s)        135,168 bytes
+
+

+ +If you don't get any results then you don't have the Java runtime system +installed. To install it go to java.com, and +click the big blue button that is on that page (it's not subtle, as you +can see from the image at right!). Be aware that Java downloads are quite +large, so if you need to install or upgrade your version of Java you should +do this when you have access to decent Internet bandwidth. +

+

+Your download will be an executable file. When you click the button there +are full details on how to download and install the software on to your +computer. +

+

+The runtime system includes everything that you need to run a Java program. +This means it has the core executables (eg java.exe), as well as +all the supporting library files needed to make Java work with your +particular operating system. However downloading the JRE alone is not +enough... +

+top + + +

The Java Development Kit (JDK)

+ +

+The JDK is a different beast to the runtime environment (JRE). You need the +JRE to actually execute Java code, and without it nothing will work. But if +you want to go further and write your own Java programs, or compile Java +code written by others, as we do here, then you will need more than the JRE +-- you will need the Java development kit. The JDK gives you the basic +tools to compile Java source code. How do you know if you have the JDK +installed? Well again arguably the quickest way is to just search your hard +drive for javac.exe (javac is the java compiler). If you get no +response you don't have the JDK installed. +

+

+As with the JRE the JDK is available for free from Sun. To download the + +version you are interested in go to the Sun +website, java.sun.com, click on the Java +SE link to the right and then choose the JDK. Alternatively you can use +their search form -- just enter "JDK". Java comes in various 'flavours': the +SE is the Standard Edition, and is the one you want; the others are EE, which +is the Enterprise Edition, and is used for creating web-based solutions using +Java Bean and Servlet technologies; and ME is the Micro Edition, used to run +Java on small devices such as phones and PDAs. [Now how cool would it be to +have Lisp on your phone? There's a thought!] +

+ +

+Make sure you download the JDK, not the JRE (unless of course you want to +upgrade your current JRE to a different version). Sun offers the JDK with some +of its other tools, such as NetBeans. NetBeans is an integrated development +environment (IDE), which lets you edit your code in a window, and then run it, +debug it, and manage your applications all within one package. There is a +learning curve to NetBeans; it is a great IDE, but if you just want to get ABCL +running you don't need all its bells and whistles. +

+

+The JDK is even bigger than the JRE. For example, JDK 6 Update 12 is 73MB. +Installation of the JDK follows the same process as for the JRE: save the +executable to disk and then execute it. This does take quite some time, so +please be patient. +

+top + + +

Ant -- the Java build tool

+ +

+Ant is an open source project managed by the Apache organisation, that is +used to manage the compilation and building of larger Java projects. It's home + +page is at ant.apache.org. To download +this tool go to their +download page. Choose the appropriate package for your platform (for +example Windows users will select the zip archive). Extract the files from +the package. Windows users can either user the built in feature of Windows +explorer: double click on the zip file; in the window that pops up click +File then Extract All (the fastest way to start Explorer: +right-click on the Start button and click Explore). +

+

+If you are on a Unix platform you can use tar to extract the files. +As the package is a tar.gz file you can use the z option to tar to +uncompress the archive, before extracting it. This command will both +uncompress and extract the archive in one go (assuming, of course, that your +archive is the 1.7.1 version of ant): +

+ +
+tar zxvf apache-ant-1.7.1-bin.tar.gz
+
+ +

+The installation +instructions are on the ant website. You should read through those to +understand what needs to be done. The description below shows how these +were applied when installing Ant on a Windows sytem. The first action that is +required is to add the Ant bin directory to your system path. From a +command prompt you can type the following commands. The first modifies the +path variable, so the bin directory is visible from anywhere. The second +command executes the ant executable. +

+ +
+C:\temp\ant\apache-ant-1.7.1>PATH=%PATH%;C:\temp\ant\apache-ant-1.7.1\bin
+
+C:\temp\ant\apache-ant-1.7.1>ant
+Unable to locate tools.jar. Expected to find it in C:\Program Files\Java\jre1.6.0_05\lib\tools.jar
+Buildfile: build.xml does not exist!
+Build failed
+C:\temp\ant\apache-ant-1.7.1>
+
+ +

+Opps! No tool.jar file. Obviously this is part of the JDK, and +so a quick search shows where it is. We can then set the JAVA_HOME +and ANT_HOME environment variables and try again: +

+ +
+C:\temp\ant\apache-ant-1.7.1>dir \tools.jar /s
+ Volume in drive C has no label.
+ Volume Serial Number is 7DDF-ABBD 
+ Directory of C:\Program Files\Java\jdk1.6.0_03\lib
+
+25/09/2007  00:11        12,171,847 tools.jar
+               1 File(s)     12,171,847 bytes
+
+     Total Files Listed:
+               3 File(s)     21,523,154 bytes
+               0 Dir(s)  11,194,011,648 bytes free
+
+C:\temp\ant\apache-ant-1.7.1>set JAVA_HOME=C:\Program Files\Java\jdk1.6.0_03
+
+C:\temp\ant\apache-ant-1.7.1>set ANT_HOME=C:\temp\ant\apache-ant-1.7.1
+
+C:\temp\ant\apache-ant-1.7.1>ant
+Buildfile: build.xml does not exist!
+Build failed
+C:\temp\ant\apache-ant-1.7.1>ant -version
+Apache Ant version 1.7.1 compiled on June 27 2008
+C:\temp\ant\apache-ant-1.7.1>
+
+ +

+Success, my build failed! (How oxymoronic is that?) Note that these changes are +only temporary. When you exit out of the command line shell you will lose +these settings. To preserve them for future shell sessions do this: +

+ +
    +
  • Click Start -- Control Panel; +
    • +
  • Double click the System item, and click on the + Advanced tab; +
    • +
  • Click the Environment Variables button; +
    • +
  • Find the PATH variable, and click Edit. + Move to the end of the path (click in the lower box and press + end), and add a semi-colon (;). Now append the path + to the Ant bin directory; +
    • +
  • Click the New system variable button, and enter the + variable name JAVA_HOME in the top box, with the + appropriate value in the lower box. Then click OK; +
    • Do the same again to set the ANT_HOME variable; +
  • Finally, close all the windows by clicking OK. +
    • +
+top + + +

Build ABCL

+ +

+OK, back to the build process. We are nearly there! You should change to the +directory where you installed the ABCL source code. Once there you can run +Ant against the build.xml file, which is the file that contains all +the build instructions Ant needs to create the target Jar file. You specify the +build file using the -f option. By default this file shows you a help +message on how to use it: +

+ +
+C:\temp\ant\apache-ant-1.7.1>cd \temp\abcl\abcl-src-0.12.0
+
+C:\temp\abcl\abcl-src-0.12.0>ant -f build.xml
+Buildfile: build.xml
+
+help:
+     [echo] Main Ant targets:
+     [echo]  abcl.compile
+     [echo]    -- compile ABCL to C:\temp\abcl\abcl-src-0.12.0/build/classes
+     [echo]  abcl.jar
+     [echo]    -- create packaged C:\temp\abcl\abcl-src-0.12.0/dist/abcl.jar
+     [echo]  abcl.wrapper
+     [echo]    -- create executable wrapper for ABCL
+     [echo]  abcl.source.zip abcl.source.tar
+     [echo]     -- create source distributions in C:\temp\abcl\abcl-src-0.12.0/dist
+     [echo]  abcl.clean
+     [echo]     -- remove ABCL intermediate files
+     [echo] Corresponding targets for J exist, but currently aren't as well tested.
+     [echo]
+
+BUILD SUCCESSFUL
+Total time: 0 seconds
+C:\temp\abcl\abcl-src-0.12.0>
+
+ +

+We want to create the JAR (Java ARchive) file. So we specify the abcl.jar +target, hit RETURN, and wait. Note that a large proportion of the output has been +removed from the listing below: +

+ +
+C:\temp\abcl\abcl-src-0.12.0>ant -f build.xml abcl.jar
+Buildfile: build.xml
+
+abcl.pre-compile:
+    [mkdir] Created dir: C:\temp\abcl\abcl-src-0.12.0\build
+    [mkdir] Created dir: C:\temp\abcl\abcl-src-0.12.0\build\classes
+     [echo] java.version: 1.6.0_03
+
+abcl.copy.lisp:
+     [copy] Copying 188 files to C:\temp\abcl\abcl-src-0.12.0\build\classes
+
+abcl.java.warning:
+     [echo] WARNING: Java version 1.6.0_03 not recommended.
+
+abcl.compile.java:
+    [javac] Compiling 257 source files to C:\temp\abcl\abcl-src-0.12.0\build\cla
+sses
+    [javac] Note: Some input files use unchecked or unsafe operations.
+    [javac] Note: Recompile with -Xlint:unchecked for details.
+
+abcl.fasls.uptodate:
+
+abcl.compile.lisp:
+     [java] Armed Bear Common Lisp 0.12.0 (built Mon Feb 23 2009 14:35:46 GMT)
+     [java] Java 1.6.0_03 Sun Microsystems Inc.
+     [java] Java HotSpot(TM) Client VM
+     [java] Low-level initialization completed in 0.731 seconds.
+     [java] Startup completed in 4.597 seconds.
+     [java] ; Compiling C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\coerce.lisp ...
+     [java] ; (IN-PACKAGE #:SYSTEM)
+     [java] ; (DECLAIM (FTYPE # ...))
+     [java] ; (DEFUN COERCE-LIST-TO-VECTOR ...)
+     [java] ; (DECLAIM (FTYPE # ...))
+     [java] ; (DEFUN COPY-STRING ...)
+     [java] ; (DEFUN COERCE-ERROR ...)
+     [java] ; (DECLAIM (FTYPE # ...))
+     [java] ; (DEFUN COERCE-OBJECT-TO-AND-TYPE ...)
+     [java] ; (DEFUN COERCE ...)
+     [java] ; Wrote C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\coerce.abcl (0.661 seconds)
+     [java] ; Compiling C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\open.lisp ...
+     [java] ; (IN-PACKAGE #:SYSTEM)
+     [java] ; (DEFUN UPGRADED-ELEMENT-TYPE-BITS ...)
+     [java] ; (DEFUN UPGRADED-ELEMENT-TYPE ...)
+     [java] ; (DEFUN OPEN ...)
+     [java] ; Wrote C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\open.abcl (0.641 seconds)
+     [java] ; Compiling C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\dump-form.lisp ...
+     [java] ; (IN-PACKAGE "SYSTEM")
+     [java] ; (DECLAIM (FTYPE # ...))
+     [java] ; (DEFUN DUMP-CONS ...)
+     [java] ; (DECLAIM (FTYPE # ...))
+     [java] ; (DEFUN DUMP-VECTOR ...)
+     [java] ; (DECLAIM (FTYPE # ...))
+
+	...
+	lots and lots of output here
+	...
+
+     [java] ; (DEFMACRO WITH-SLOTS ...)
+     [java] ; Wrote C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\with-slots.abcl (0.11 seconds)
+     [java] ; Compiling C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\with-standard-io-syntax.lisp ...
+     [java] ; (IN-PACKAGE "SYSTEM")
+     [java] ; (DEFUN %WITH-STANDARD-IO-SYNTAX ...)
+     [java] ; (DEFMACRO WITH-STANDARD-IO-SYNTAX ...)
+     [java] ; Wrote C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\with-standard-io-syntax.abcl (0.131 seconds)
+     [java] ; Compiling C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\with-thread-lock.lisp ...
+     [java] ; (IN-PACKAGE "EXTENSIONS")
+     [java] ; (DEFMACRO WITH-THREAD-LOCK ...)
+     [java] ; Wrote C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\with-thread-lock.abcl (0.08 seconds)
+     [java] ; Compiling C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\write-sequence.lisp ...
+     [java] ; (IN-PACKAGE #:SYSTEM)
+     [java] ; (DEFUN WRITE-SEQUENCE ...)
+     [java] ; Wrote C:\temp\abcl\abcl-src-0.12.0\build\classes\org\armedbear\lisp\write-sequence.abcl (0.09 seconds)
+     [java] 283.678 seconds real time
+     [java] 71118074 cons cells
+
+abcl.compile:
+     [echo] Compiled ABCL with java version: 1.6.0_03
+
+abcl.stamp:
+
+abcl.pre-compile:
+     [echo] java.version: 1.6.0_03
+
+abcl.copy.lisp:
+
+abcl.java.warning:
+     [echo] WARNING: Java version 1.6.0_03 not recommended.
+
+abcl.compile.java:
+
+abcl.fasls.uptodate:
+
+abcl.compile.lisp:
+
+abcl.compile:
+     [echo] Compiled ABCL with java version: 1.6.0_03
+
+abcl.stamp.version:
+     [echo] Building ABCL version: 0.12.0
+
+abcl.stamp.hostname:
+     [echo] abcl.hostname: IBM-D396A533B48
+
+abcl.jar:
+      [jar] Building jar: C:\temp\abcl\abcl-src-0.12.0\dist\abcl.jar
+
+BUILD SUCCESSFUL
+Total time: 6 minutes 6 seconds
+C:\temp\abcl\abcl-src-0.12.0>
+
+

+The last line of output is our target file: +C:\temp\abcl\abcl-src-0.12.0\dist\abcl.jar. This is actually quite an +intelligent JAR file, as it knows the name of the main Java class to run. This +means quite a lot of the complexity of actually running the application is +hidden from the user. So we can run the JAR file from the command line, using +java.exe with only its -jar option: +

+ +
+C:\temp\abcl\abcl-src-0.12.0>dir C:\temp\abcl\abcl-src-0.12.0\dist\abcl.jar
+ Volume in drive C has no label.
+ Volume Serial Number is 7DDF-ABBD 
+
+ Directory of C:\temp\abcl\abcl-src-0.12.0\dist
+
+23/02/2009  14:41         5,634,488 abcl.jar
+               1 File(s)      5,634,488 bytes
+               0 Dir(s)  11,169,034,240 bytes free
+
+C:\temp\abcl\abcl-src-0.12.0>java -jar C:\temp\abcl\abcl-src-0.12.0\dist\abcl.jar
+Armed Bear Common Lisp 0.12.0
+Java 1.6.0_05 Sun Microsystems Inc.
+Java HotSpot(TM) Client VM
+Low-level initialization completed in 2.413 seconds.
+Startup completed in 6.519 seconds.
+Type ":help" for a list of available commands.
+CL-USER(1):
+
+

Winner! We now have a working version of ABCL. Put the JAR file on a memory +stick or CD and you have your own personal Lisp system available to you where +ever you are. Now how cool is that? +

+ +top +

Running ABCL on Linux

+

+Because ABCL is a Java application, it should in theory be possible to run this +on any computer where the Java Virtual Machine (JVM) is installed. However, if +you wish to run this on Linux you need to perform the following actions to +allow ABCL to run correctly. If you just run the JAR file, then you will find +the arrow keys (ie up, down, left and right) do not function correctly. +Instead, you get output as shown below (here the keys entered were, in order, +up, right, down, and left): +

+ +
+Armed Bear Common Lisp 0.12.0
+Java 1.6.0 IBM Corporation
+IBM J9 VM
+Low-level initialization completed in 0.718 seconds.
+Startup completed in 2.411 seconds.
+Type ":help" for a list of available commands.
+CL-USER(1): ^[[A^[[C^[[B^[[D
+
+ +

+Here you can see that you are not getting the correct response. You need to +get the tool rlwrap. To +use this you need to first install the software. Download the source code, the +current version of which is in + +rlwrap-0.30.tar.gz. Extract the contents to your system. For example, if +you want to extract into /tmp save the file to somewhere on your +system, and then run this command: +

+ +
+cd /tmp
+tar zxvf /path/to/rlwrap-0.30.tar.gz
+
+ +

+In this case it will create the directory /tmp/rlwrap-0.30.tar.gz +To perform the remaining commands you should su to root. This will then +allow you to intall the binary in /usr/local/bin. Run the following +commands as root: +

+
+cd /tmp/rlwrap-0.30
+./configure
+make
+make install
+
+ + +

+Now we need to create the file .abcl_completions. To do this save +the following Lisp code to a file, say test.lisp: +

+ +
+(do-all-symbols (sym)
+  (let ((package (symbol-package sym)))
+       (cond
+         ((not (fboundp sym)))
+         ((or (eql #.(find-package :cl) package)
+              (eql #.(find-package :extensions) package)
+              (eql #.(find-package :cl-user) package))
+          (pushnew (symbol-name sym) symbols))
+         ((eql #.(find-package :keyword) package)
+          (pushnew (concatenate 'string ":" (symbol-name sym)) symbols))
+         (package
+           (pushnew (concatenate 'string
+                                 (package-name package)
+                                 ":"
+                                 (symbol-name sym))
+                    symbols)))))
+(with-open-file (output #.(concatenate 'string
+                                       (getenv "HOME")
+                                       "/.abcl_completions")
+                        :direction :output :if-exists :overwrite
+                        :if-does-not-exist :create)
+  (format output "~{~(~A~)~%~}" (sort symbols #'string<)))
+(quit))
+
+ +

+Now create the .abcl_completions by running this command: +

+ +
+java -jar abcl.jar --load test.lisp
+
+ +

+The final (quit) ensures this Lisp command returns you to the +command line when it completes. It creates the .abcl_completions +file in your home directory. We still need to do one more thing, before we +create the lisp executable. If you need to know the path to the +abcl.jar file If you don't know what it is you can search for it: +

+ +
+find / 2>/dev/null -name abcl.jar
+
+ +

+If this does not return any names, try replacing abcl.jar with +abcl\*.jar, as the JAR file may have a version number included. +Consider that the filename returned is /opt/abcl/abcl.jar, then we will +need the line ABCL_JAR=/opt/abcl/abcl.jar in our script. So bearing +this in mind, we can now create a script file that we can call +/usr/local/bin/lisp: +

+ +
+#!/bin/sh
+ABCL_JAR=/opt/abcl/abcl.jar	# Use your own path here.
+JAVA=$(which java)
+ABCL="$JAVA -server -Xrs -cp $ABCL_JAR org.armedbear.lisp.Main"
+if [ $# -eq 0 ]; then
+	exec rlwrap -b "[]()'\" " --remember -c -f ~/.abcl_completions \
+				  -H ~/.abcl_history -s 1000000 $ABCL
+else
+	exec $ABCL "$@"
+fi
+
+ +

+Now when you use this lisp command you will get the keystroke behaviour +you expect. +

+ +top +home + + Added: public_html/doc/abcl-lisp-java-integration.html ============================================================================== --- (empty file) +++ public_html/doc/abcl-lisp-java-integration.html Fri May 22 17:46:35 2009 @@ -0,0 +1,89 @@ + + + + +Installing armedbear the Java way + + + + + + + +

armedbear

+ +home + +
+
+C:\temp\abcl\abcl-src-0.12.0\dist>java -jar abcl.jar
+Armed Bear Common Lisp 0.12.0
+Java 1.6.0_05 Sun Microsystems Inc.
+Java HotSpot(TM) Client VM
+Low-level initialization completed in 1.262 seconds.
+Startup completed in 4.556 seconds.
+Type ":help" for a list of available commands.
+CL-USER(1): (list 'welcome 'to 'lisp!)
+(WELCOME TO LISP!)
+CL-USER(2):
+
+
+

Integrating Lisp into Java

+ +

+This page describes you can use ABCL to integrate Lisp into a Java application. +Why is this useful? Well, you get the best of both worlds -- you get the +power of Java and can call upon the very large number of existing tools and +programs that have been implemented in Java, and merge this with the incredible +poower of Lisp. So if you have a useful Lisp application rather you no longer +need to rewrite it in Java. Simply call the ABCL Lisp interpreter to execute +its Lisp code. +

+ +

How to compile your Java-Lisp code

+

+Your Java code will use the special classes provided by ABCL to allow it to +access the methods needed to interact with your Lisp code. This means that the +ABCL JAR file needs to appear in your CLASSPATH. Depending on how you build +your application will depend on the method you choose to use. The simplest +method is to use the -cp option to the Java compiler. Alternatively +you can set the CLASSPATH environment variable, thus simplifying the +Java command line. Finally you may set the CLASSPATH in your IDE, or using the +Ant <classpath> tag. To make this more concrete consider you +have a Java file called myapp.java. Then if you use the javac +command to run the Java compiler, your command may look like this (we are, of +course, describing a Windows platform): +

+
+javac -cp c:\path\to\abcl.jar myapp.java
+
+

+Of course if you have other elements in your classpath you will have to make +the path more complex to take this into account. So, for example, if you have +other JAR files in c:\apps\java-libs, and the JAR file +c:\3rd-party-apps\lib\special-tools.jar, the command will have to be +modified to look like this: +

+
+javac -cp c:\path\to\abcl.jar;c:\apps\java-libs;c:\3rd-party-apps\lib\special-tools.jar myapp.java
+
+

+It is clear from the above that the command is getting more and more complex. +As you add more classes to the commmand line so it will grow, and perhaps +exceed the maximum command line length. The general solution to this is to +take the class path information out of the command and store it in an +environment variable called CLASSPATH: +

+
+set CLASSPATH=c:\path\to\abcl.jar;c:\apps\java-libs;c:\3rd-party-apps\lib\special-tools.jar
+javac myapp.java
+
+

+

+ + Added: public_html/doc/abcl-start.html ============================================================================== --- (empty file) +++ public_html/doc/abcl-start.html Fri May 22 17:46:35 2009 @@ -0,0 +1,208 @@ + + + + +Installing armedbear the Java way + + + + + + + +

armedbear

+ +home + +
+
+C:\temp\abcl\abcl-src-0.12.0\dist>java -jar abcl.jar
+Armed Bear Common Lisp 0.12.0
+Java 1.6.0_05 Sun Microsystems Inc.
+Java HotSpot(TM) Client VM
+Low-level initialization completed in 1.262 seconds.
+Startup completed in 4.556 seconds.
+Type ":help" for a list of available commands.
+CL-USER(1): (list 'welcome 'to 'lisp!)
+(WELCOME TO LISP!)
+CL-USER(2):
+
+
+

Starting ABCL

+ +

+When you start ABCL you can pass it command line arguments. Currently (at +version 12) it supports the following arguments: +

+ +
    +
  • --noinit If you have defined an + initialisation file you can use this option to prevent this file + from being processed when the application starts. +
    • +
  • --noinform Suppresses the + information that is normally printed when the application starts. +
    • +
  • --batch See batch below. +
    • +
  • --eval See eval below.This requires + an argument. +
    • +
  • --load See load below. This requires + an argument. +
    • +
  • --load-system-file See + load-system-file below. This + requires an argument. +
    • +
+ +

+

+ + +

The --noinform option

+

+The --noinform option stops the normal startup messsages from appearing. +A normal startup will look something like this: +

+ +
+C:\temp\abcl\abcl-src-0.12.0\dist>java -jar abcl.jar
+Armed Bear Common Lisp 0.12.0
+Java 1.6.0_05 Sun Microsystems Inc.
+Java HotSpot(TM) Client VM
+Low-level initialization completed in 1.262 seconds.
+Startup completed in 4.556 seconds.
+Type ":help" for a list of available commands.
+CL-USER(1):
+
+ +

+To stop the above messages from appearing simply add the --noinform +option to the end of the comand line: +

+ +
+C:\temp\abcl\abcl-src-0.12.0\dist>java -jar abcl.jar --noinform
+CL-USER(1):
+
+ + +top +

The --batch option

+

+It is currently not known what this option does. +

+ + + +top +

The --eval option

+

+It is currently not known what this option does. +No idea what this does, but under Linux it seems to mess up the keystrokes. +If you start your Lisp under +Linux, the keystrokes are not recognised. Consider starting ABCL Lisp with +this command: lisp --eval "(+ 1 2)". When you try to use the arrow +keys (up, right, down and left) you get: +

+ +
+[localhost ~]$ lisp --eval "(+ 1 2)"
+Armed Bear Common Lisp 0.12.0
+Java 1.6.0 IBM Corporation
+IBM J9 VM
+Low-level initialization completed in 0.639 seconds.
+Startup completed in 2.221 seconds.
+Type ":help" for a list of available commands.
+CL-USER(1): ^[[A^[[C^[[B^[[D
+
+ + + +top +

The --load option

+

+This option must be followed by a filename. It allows you to load a file when +the Lisp system starts. Consider the following Lisp file; it conists of a +single form: +

+ +
+(format t "Hello world")
+
+ +

+If this file is saved in your home directory in Linux and is called +test.lisp, you can load the file into Lisp with lisp --load +~/test.lisp. Now, when Lisp starts up you will see: +

+ +
+[localhost ~]$ pwd
+/home/test-user
+[localhost ~]$ cat test.lisp
+(format t "Hello World!")
+[localhost ~]$ lisp --load ~/test.lisp 
+Armed Bear Common Lisp 0.12.0
+Java 1.6.0 IBM Corporation
+IBM J9 VM
+Low-level initialization completed in 0.686 seconds.
+Startup completed in 2.325 seconds.
+Hello World!
+Type ":help" for a list of available commands.
+CL-USER(1): 
+
+ +

+

+ + +top +

The --load-system-file option

+

+This looks for lisp files. If there is no extension it tries an extension of +.abcl, .lisp (from Load.loadSystemFile()) +

+ + +top +

ABCL initialisation file

+

+ABCL supports an initialisation file, with the expected name of .abclrc +The system looks for this file in the directory specified by the Java system +property user.home. This property should point to the user's home +directory. If this file does not exist, then for Windows users the next place +to look for it is in the root directory of the c: drive: +C:\.abclrc. If this does not exist, the file .ablrc in the +user's home directory is tried next; this option is depcrecated and only exists +for backward compatibility. You should use .abclrc instead. Finally +if all the above fail the last filename searched for is .ablisprc. +

+ +

+As an example, make sure you are in your home directory, and create a file +called .abclrc. To demonstrate that this works enter the following +Lisp form into this file: (setf x 3). This will set the special +variable x to the value 3. Now simply start Lisp, and query the +variable x: +

+ +
+C:\temp\abcl\abcl-src-0.12.0\dist>java -jar abcl.jar
+CL-USER(1): x
+3
+
+ +

+The initialisation file is loaded before any other file is loaded. +

+ + + Added: public_html/doc/ant-apache-org.jpg ============================================================================== Binary file. No diff available. Added: public_html/doc/getting-started.txt ============================================================================== --- (empty file) +++ public_html/doc/getting-started.txt Fri May 22 17:46:35 2009 @@ -0,0 +1,48 @@ +So now you have the ABCL Lisp system compiled, and can run the resulting JAR +file to give you a Lisp prompt, what do you do with it? + +* First, get that JAR file onto a pendrive. You can take Lisp with you + where-ever you go. Now how cool is that? +* Lisp IS NOT an artificial intelligence (AI) programming language. It IS a + general purpose programming language, can can, as well, do AI stuff. +* Lisp is a refreshing alternative to the Fortran-like languages you see all + around you (C, C++, Java, PHP, etc). Its syntax is weird and different, + and very flexible (well to be honest Lisp doesn't really have any + syntax, which is why it is so flexible). +* Start by trying to get into the Lisp way of programming. Try to write code + in Lisp instead of your current programming language. For example, try + to write Lisp versions of what you would do in Java. +* Lisp is a big language, but once you have learned a small element, the rest + of the language will become obvious -- it has everything you need. As + your knowledge grows, so you will see there is an answer in Lisp. (This + is just like Java or C++, once you know the basics you can simply write + your own, or hunt down the ready-made solutions that the language has + -- somewhere. +* Lisp is very flexible. You won't see this until you've been using it awhile, + but you will find that it is the most natural way to think through + solutions. +* There are lots of Lisp textbooks around. Don't be worried if these are 20 + years old or more. You will still say 'wow' when you see what sort of + things are in these books. The things you can do with functions is + amazing -- but you don't know this because your current languages don't + support it, so you don't think that way. +* Finally, write Lisp code. Everytime you have to solve a problem in Java or + C++, think about how you could do it in Lisp. + +Java/Lisp examples. + +------------------------------------------------------------------------------- +Count to 10: +Java + + for(i = 1; i < 11; i++) { + System.out.println("i=" + i); + } + +Lisp + + (dotimes (x 10) + (print (1+ x))) + +------------------------------------------------------------------------------- + Added: public_html/doc/javajdk.jpg ============================================================================== Binary file. No diff available. Added: public_html/doc/javajre.jpg ============================================================================== Binary file. No diff available. From ehuelsmann at common-lisp.net Sat May 23 09:40:16 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 23 May 2009 05:40:16 -0400 Subject: [armedbear-cvs] r11931 - public_html/staging Message-ID: Author: ehuelsmann Date: Sat May 23 05:40:13 2009 New Revision: 11931 Log: Create staging area for website. Added: public_html/staging/ - copied from r11930, /public_html/ From ehuelsmann at common-lisp.net Sat May 23 09:46:06 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 23 May 2009 05:46:06 -0400 Subject: [armedbear-cvs] r11932 - public_html/staging Message-ID: Author: ehuelsmann Date: Sat May 23 05:46:03 2009 New Revision: 11932 Log: Work-in-progress commit. Added: public_html/staging/release-notes-0.15.shtml (contents, props changed) - copied, changed from r11757, /public_html/release-notes-0.14.shtml Modified: public_html/staging/index.shtml public_html/staging/style.css Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sat May 23 05:46:03 2009 @@ -3,7 +3,7 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> - <!--#include virtual="project-name" --> + Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM + + + +
+

Contributing: Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM

+
+ + + +
+
+ +
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id$
+
+ + Added: public_html/staging/faq.shtml ============================================================================== --- (empty file) +++ public_html/staging/faq.shtml Sat May 23 16:33:09 2009 @@ -0,0 +1,61 @@ + + + + + FAQ: Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM + + + + + + +
+

FAQ: Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM

+
+ + + +
+

Index

+
    +
  1. General +
      +
    1. abcl
      2. +
    +
    2. +
+
+ + +
+

General

+ + +
+

abcl

+ + +
+ + +
+ + + +
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id$
+
+ + Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sat May 23 16:33:09 2009 @@ -9,6 +9,8 @@ @@ -21,10 +23,19 @@
+ + + @@ -73,7 +85,13 @@ Added: public_html/staging/toctool.py ============================================================================== --- (empty file) +++ public_html/staging/toctool.py Sat May 23 16:33:09 2009 @@ -0,0 +1,257 @@ +#!/usr/bin/env python + +"""\ +This tool regenerates and replaces the ToC in an HTML file from the actual +structure of
s and s present in the body of the document. +The section to be overwritten is identified as the XML subtree +rooted at
    . + +Usage: ./toctool.py filename... + +This file is a copy of r37798 from the Subversion repository. + +""" + +import sys +import os +import xml.parsers.expat + + +class Index: + def __init__(self): + self.title = None + self.tree = [] + self._ptr_stack = [self.tree] + + def addLevel(self, id, title): + newlevel = [(id, title)] + self._ptr_stack[-1].append(newlevel) + self._ptr_stack.append(newlevel) + + def upLevel(self): + self._ptr_stack.pop(-1) + + def prettyString(self): + out = [] + def step(ilevel, node): + if isinstance(node, list): + for subnode in node: + step(ilevel+1, subnode) + else: + out.append("%s%s" % (" "*ilevel, node)) + step(-2, self.tree) + return "\n".join(out) + + def renderXML(self): + out = [] + def step(ilevel, node): + if len(node) == 1: + out.append('%s
  1. %s
    2. ' + % (' '*ilevel, node[0][0], node[0][1])) + else: + out.append('%s
  2. %s' + % (' '*ilevel, node[0][0], node[0][1])) + out.append('%s
      ' % (' '*ilevel)) + for subnode in node[1:]: + step(ilevel+1, subnode) + out.append('%s
    ' % (' '*ilevel)) + out.append('%s
    3. ' % (' '*ilevel, node[0][0])) + out.append('
      ') + for node in self.tree: + step(1, node) + out.append('
    ') + return "\n".join(out) + + +class ExpatParseJob: + def parse(self, file): + p = xml.parsers.expat.ParserCreate() + p.ordered_attributes = self._ordered_attributes + p.returns_unicode = False + p.specified_attributes = True + for name in dir(self): + if name.endswith('Handler'): + setattr(p, name, getattr(self, name)) + p.ParseFile(file) + + +class IndexBuildParse(ExpatParseJob): + keys = {'h2':None, 'h3':None, 'h4':None, 'h5':None} + + def __init__(self): + self.index = Index() + self.keyptr = 0 + self.collecting_text = False + self.text = '' + self.waiting_for_elt = None + self.saved_id = None + self.elt_stack = [] + self._ordered_attributes = False + + def StartElementHandler(self, name, attrs): + if name == 'div': + cl = attrs.get('class') + if cl in self.keys: + self.waiting_for_elt = cl + self.saved_id = attrs.get('id') + self.elt_stack.append((name, True)) + return + elif name == 'title': + self.collecting_text = name + self.text = '' + elif name == self.waiting_for_elt: + self.waiting_for_elt = None + self.collecting_text = name + self.text = '' + self.elt_stack.append((name, False)) + + def EndElementHandler(self, name): + if self.collecting_text: + if name == self.collecting_text: + if name == 'title': + self.index.title = self.text + else: + self.index.addLevel(self.saved_id, self.text) + self.saved_id = None + self.collecting_text = False + else: + raise RuntimeError('foo') + eltinfo = self.elt_stack.pop(-1) + assert eltinfo[0] == name + if eltinfo[1]: + self.index.upLevel() + + def DefaultHandler(self, data) : + if self.collecting_text: + self.text += data + + +def attrlist_to_dict(l): + d = {} + for i in range(0, len(l), 2): + d[l[i]] = l[i+1] + return d + + +def escape_entities(s): + return s.replace('&', '&').replace('<', '<').replace('>', '>') + + +class IndexInsertParse(ExpatParseJob): + def __init__(self, index, outfp): + self._ordered_attributes = True + self.index = index + self.outfp = outfp + self.elt_stack = [] + self.skipping_toc = False + + self._line_in_progress = [] + self._element_open = None + self.linepos = 0 + self.indentpos = 0 + + self.do_not_minimize = {'script':None} + self.do_not_indent = {'div':None, 'a':None, 'strong':None, 'em':None} + self.do_not_wrap = {'div':None, 'strong':None, 'em':None, 'li':None} + + if self.index.title == 'Subversion Design': + self.do_not_wrap['a'] = None + + def put_token(self, token, tag_name): + self._line_in_progress.append((token, tag_name)) + + def done_line(self): + linepos = 0 + last_was_tag = False + outq = [] + for token, tag_name in self._line_in_progress: + is_tag = tag_name is not None and tag_name not in self.do_not_wrap + no_indent_if_wrap = tag_name in self.do_not_indent + linepos += len(token) + if linepos > 79 and is_tag and last_was_tag: + token = token.lstrip(' ') + if no_indent_if_wrap: + linepos = len(token) + outq.append('\n') + else: + linepos = len(token) + 2 + outq.append('\n ') + outq.append(token) + last_was_tag = is_tag + outq.append('\n') + for i in outq: + self.outfp.write(i) + del self._line_in_progress[:] + + def _finish_pending(self, minimized_form): + if self._element_open is not None: + name = self._element_open + self._element_open = None + if minimized_form: + self.put_token(' />', name) + return True + else: + self.put_token('>', name) + return False + + def StartElementHandler(self, name, attrs): + self._finish_pending(False) + if name == 'ol' and attrlist_to_dict(attrs).get('id') == 'toc': + self.outfp.write(self.index.renderXML()) + self.skipping_toc = True + self.elt_stack.append((name, True)) + return + if not self.skipping_toc: + self.put_token("<%s" % name, name) + while attrs: + aname = attrs.pop(0) + aval = escape_entities(attrs.pop(0)) + self.put_token(' %s="%s"' % (aname, aval), name) + self._element_open = name + self.elt_stack.append((name, False)) + + def EndElementHandler(self, name): + if not self.skipping_toc: + if not self._finish_pending(name not in self.do_not_minimize): + self.put_token("" % name, name) + eltinfo = self.elt_stack.pop(-1) + assert eltinfo[0] == name + if eltinfo[1]: + self.skipping_toc = False + + def DefaultHandler(self, data): + if self.skipping_toc: + return + self._finish_pending(False) + # This makes an unsafe assumption that expat will pass '\n' as individual + # characters to this function. Seems to work at the moment. + # Will almost certainly break later. + if data == '\n': + self.done_line() + else: + self.put_token(data, None) + + +def process(fn): + infp = open(fn, 'r') + builder = IndexBuildParse() + builder.parse(infp) + + infp.seek(0) + outfp = open(fn + '.new', 'w') + inserter = IndexInsertParse(builder.index, outfp) + inserter.parse(infp) + + infp.close() + outfp.close() + os.rename(fn, fn + '.toctool-backup~') + os.rename(fn + '.new', fn) + + +def main(): + for fn in sys.argv[1:]: + process(fn) + + +if __name__ == '__main__': + main() From ehuelsmann at common-lisp.net Sat May 23 20:45:39 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 23 May 2009 16:45:39 -0400 Subject: [armedbear-cvs] r11938 - public_html/staging Message-ID: Author: ehuelsmann Date: Sat May 23 16:45:37 2009 New Revision: 11938 Log: Publish discussion again. Modified: public_html/staging/index.shtml Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sat May 23 16:45:37 2009 @@ -21,13 +21,13 @@ -
    +
Project description
ABCL is a full implementation of the Common Lisp language + featuring both an interpreter and a compiler, running in the JVM. Originally + started to be a scripting language for the J editor, it now supports JSR-233 + (Java scripting): it can be a scripting engine in any Java application. +
+Download your copy from SourceForge: 0.15.0
Feature list Users (development with ABCL)
    +
  • Full Common Lisp implementation
  • Many JVM host environments (Sun, IBM, ...)
  • Interpreter
  • Compiler
    • @@ -35,7 +46,7 @@
-System requirements +
+
Licensing
+
The implementation is covered by the GNU General Public License + with Classpath exception.
+
System requirements
+
Using (developing with ABCL)
@@ -81,7 +99,7 @@
  • Java Runtime (JRE)
  • Java version 1.5.0 (any patch level) or 1.6.0 (patch level 10 or higher)
  • Any operating system, although explicitly supported:
    - Windows, MacOS X, OpenBSD, NetBSD and FreeBSD and Google App Engine
    • + Windows, Linux, MacOS X, OpenBSD, NetBSD and FreeBSD and Google App Engine
    Building (developing of ABCL)
    @@ -91,6 +109,8 @@
  • Same versions as for using
    • + +
    - From ehuelsmann at common-lisp.net Sat May 23 21:45:54 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 23 May 2009 17:45:54 -0400 Subject: [armedbear-cvs] r11939 - public_html/staging Message-ID: Author: ehuelsmann Date: Sat May 23 17:45:52 2009 New Revision: 11939 Log: Commit further progress. Modified: public_html/staging/index.shtml Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sat May 23 17:45:52 2009 @@ -23,27 +23,21 @@
    Project description
    ABCL is a full implementation of the Common Lisp language - featuring both an interpreter and a compiler, running in the JVM. Originally - started to be a scripting language for the J editor, it now supports JSR-233 - (Java scripting): it can be a scripting engine in any Java application. +
    ABCL is a full implementation of the Common Lisp language + featuring both an interpreter and a compiler, running in the JVM. Originally + started to be a scripting language for the J editor, it now supports JSR-233 + (Java scripting API): it can be a scripting engine in any Java application.
    Download your copy from SourceForge: 0.15.0
    - - + - - - - + + + + + - - - - - - + + + + + + + + + + + + + - @@ -51,7 +51,7 @@ - - - - - - - - @@ -91,33 +72,26 @@ - + + - +
    Project description
    ABCL is a full implementation of the Common Lisp language +
    Project description
    ABCL is a full implementation of the Common Lisp language featuring both an interpreter and a compiler, running in the JVM. Originally started to be a scripting language for the J editor, it now supports JSR-233 (Java scripting API): it can be a scripting engine in any Java application. + Additionally, it can be used to implement (parts of) the application + using Java to Lisp integration APIs.
    +
    Download your copy from SourceForge: 0.15.0
    Feature listUsers (development with ABCL)
    -
      -
    • Full Common Lisp implementation
      • -
    • Many JVM host environments (Sun, IBM, ...)
      • -
    • Interpreter
      • -
    • Compiler
      • -
    • Integration with Java programs
      • -
    • Java Scripting support (JSR-233)
      • -
    • ...
      • -
    -
    Users (development with ABCL)Developers (development of ABCL)
    • FAQ
      • @@ -55,12 +49,6 @@
    • Bug reporting
    Developers (development of ABCL) Availability
    System requirements (Users)System requirements (Developers)
    +
      +
    • JRE 1.5.0 (any patch level), or
      • +
    • JRE 1.6.0 (patch level 10 or higher)
      • +
    		 -Latest version: 0.15.0
      -
    • Download (from SourceForge)
      • -
    • Release notes
      • -
    • Change history
      • +
    • JDK 1.5.0 (any patch level), or
      • +
    • JDK 1.6.0 (patch level 10 or higher)
      • +
    • Ant version 1.7.0 or higher
    Licensing
    +Armed Bear CL is covered by the +GNU General Public License with +Classpath exception, meaning that you can +distribute ABCL with your application without the requirement to open the +sources to your application. +
    General information
    -
    Licensing
    -
    The implementation is covered by the GNU General Public License - with Classpath exception.
    System requirements
    From astalla at common-lisp.net Sat May 23 22:44:27 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Sat, 23 May 2009 18:44:27 -0400 Subject: [armedbear-cvs] r11940 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sat May 23 18:44:26 2009 New Revision: 11940 Log: Fixed a bug in interpreted let* and do*: the environment used for bindings was a single one, shared with all the initforms and the body. This caused closures in initforms to capture newly-introduced bindings. The fix amounts to creating a new extended environment for every binding. In passing a typo was fixed in java.lisp. Modified: trunk/abcl/src/org/armedbear/lisp/Do.java trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java trunk/abcl/src/org/armedbear/lisp/java.lisp 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 Sat May 23 18:44:26 2009 @@ -101,11 +101,12 @@ LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); body = bodyAndDecls.car(); - final Environment ext = new Environment(env); + Environment ext = new Environment(env); for (int i = 0; i < numvars; i++) { Symbol var = vars[i]; LispObject value = eval(initforms[i], (sequential ? ext : env), thread); + ext = new Environment(ext); if (specials != NIL && memq(var, specials)) thread.bindSpecial(var, value); else if (var.isSpecialVariable()) Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Sat May 23 18:44:26 2009 @@ -143,8 +143,10 @@ symbol = checkSymbol(obj); value = NIL; } - if (sequential) + if (sequential) { + ext = new Environment(ext); bindArg(specials, symbol, value, ext, thread); + } else nonSequentialVars.add(new Cons(symbol, value)); varList = ((Cons)varList).cdr; Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Sat May 23 18:44:26 2009 @@ -288,7 +288,7 @@ ((jinstance-of-p object "java.lang.Class") `(java:jclass ,(jcall (jmethod "java.lang.Class" "getName") object))) (t - (error "Unknown load-from for ~A" class-name))))) + (error "Unknown load-form for ~A" class-name))))) (defun jproperty-value (obj prop) (%jget-property-value obj prop)) From ehuelsmann at common-lisp.net Sun May 24 08:47:27 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 24 May 2009 04:47:27 -0400 Subject: [armedbear-cvs] r11941 - public_html/staging Message-ID: Author: ehuelsmann Date: Sun May 24 04:47:21 2009 New Revision: 11941 Log: Start moving links from "below" to "up there". Modified: public_html/staging/index.shtml Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sun May 24 04:47:21 2009 @@ -31,7 +31,7 @@ Additionally, it can be used to implement (parts of) the application using Java to Lisp integration APIs.
    +
    Download your copy from SourceForge: 0.15.0
    Users (development with ABCL)
    System requirements (Users)System requirements (Developers)
    -
      -
    • JRE 1.5.0 (any patch level), or
      • -
    • JRE 1.6.0 (patch level 10 or higher)
      • -
    -    		 -
      -
    • JDK 1.5.0 (any patch level), or
      • -
    • JDK 1.6.0 (patch level 10 or higher)
      • -
    • Ant version 1.7.0 or higher
      • -
    -
    Licensing
    General informationSystem requirements (Users)System requirements (Developers)
    -
    -
    System requirements
    -
    -
    -
    Using (developing with ABCL)
    -
    +
      -
    • Java Runtime (JRE) -
    • Java version 1.5.0 (any patch level) or 1.6.0 (patch level 10 or higher)
      • -
    • Any operating system, although explicitly supported:
      - Windows, Linux, MacOS X, OpenBSD, NetBSD and FreeBSD and Google App Engine
      • +
    • JRE 1.5.0 (any patch level), or
      • +
    • JRE 1.6.0 (patch level 10 or higher)
      • +
    • One of the explicitly supported platforms:
      + Windows, Linux, MacOS X, OpenBSD, NetBSD,
      + FreeBSD or Google App Engine
    - -
    Building (developing of ABCL)
    -
    +
      -
    • Java Development Kit (JDK)
      • -
    • Same versions as for using
      • - - - - - +
    • JDK 1.5.0 (any patch level), or
      • +
    • JDK 1.6.0 (patch level 10 or higher)
      • +
    • Ant version 1.7.0 or higher, or
      • +
    • A Lisp to run the lisp-based build system
      • +
    @@ -165,19 +139,6 @@

    - Download -

    -
    -
    - - abcl-src-0.15.0.tar.gz - (source, ????? bytes) -

    - abcl-src-0.15.0.zip - (source, ??????? bytes) -
    -
    -

    Repository

    @@ -241,16 +202,7 @@
    The README file in the root directory of the source distribution contains - instructions for building ABCL. -

    - Java 1.5 or higher is required; - Java 1.5 - is recommended. There are - - performance issues with versions of Java 1.6 prior to update 10. - To build ABCL, you'll need the full JDK; the JRE is not enough.
    - Recent performance tests have shown Java 1.6 Update 10 (and newer) - to be as fast as Java 1.5.
    + instructions for building ABCL.
    From vvoutilainen at common-lisp.net Sun May 24 08:59:25 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 24 May 2009 04:59:25 -0400 Subject: [armedbear-cvs] r11942 - public_html/staging Message-ID: Author: vvoutilainen Date: Sun May 24 04:59:16 2009 New Revision: 11942 Log: Slight rephrasing of the effect of the Classpath exception. Modified: public_html/staging/index.shtml Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sun May 24 04:59:16 2009 @@ -67,7 +67,7 @@ Armed Bear CL is covered by the GNU General Public License with Classpath exception, meaning that you can -distribute ABCL with your application without the requirement to open the +use ABCL in your application without the requirement to open the sources to your application. From vvoutilainen at common-lisp.net Sun May 24 09:01:25 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 24 May 2009 05:01:25 -0400 Subject: [armedbear-cvs] r11943 - public_html/staging Message-ID: Author: vvoutilainen Date: Sun May 24 05:01:23 2009 New Revision: 11943 Log: Use ABCL or Armed Bear Common Lisp, not Armed Bear CL. Modified: public_html/staging/index.shtml Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sun May 24 05:01:23 2009 @@ -64,7 +64,7 @@ -Armed Bear CL is covered by the +ABCL is covered by the GNU General Public License with Classpath exception, meaning that you can use ABCL in your application without the requirement to open the From ehuelsmann at common-lisp.net Sun May 24 09:06:26 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 24 May 2009 05:06:26 -0400 Subject: [armedbear-cvs] r11944 - public_html/staging Message-ID: Author: ehuelsmann Date: Sun May 24 05:06:18 2009 New Revision: 11944 Log: Add links. Modified: public_html/staging/index.shtml Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sun May 24 05:06:18 2009 @@ -32,7 +32,7 @@ using Java to Lisp integration APIs. -Download your copy from SourceForge: 0.15.0 +Download your copy from SourceForge: 0.15.0 (zip) Users (development with ABCL) Developers (development of ABCL) @@ -88,7 +88,7 @@ From vvoutilainen at common-lisp.net Sun May 24 09:23:21 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 24 May 2009 05:23:21 -0400 Subject: [armedbear-cvs] r11945 - public_html/staging Message-ID: Author: vvoutilainen Date: Sun May 24 05:23:18 2009 New Revision: 11945 Log: Download link for ant, and a direct one for our current preferred version. Modified: public_html/staging/index.shtml Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sun May 24 05:23:18 2009 @@ -89,7 +89,7 @@ From vvoutilainen at common-lisp.net Sun May 24 09:35:28 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 24 May 2009 05:35:28 -0400 Subject: [armedbear-cvs] r11946 - public_html/staging Message-ID: Author: vvoutilainen Date: Sun May 24 05:35:26 2009 New Revision: 11946 Log: Point ant main link to ant main page. Modified: public_html/staging/index.shtml Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sun May 24 05:35:26 2009 @@ -89,7 +89,7 @@ From ehuelsmann at common-lisp.net Sun May 24 09:54:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 24 May 2009 05:54:02 -0400 Subject: [armedbear-cvs] r11947 - public_html/staging Message-ID: Author: ehuelsmann Date: Sun May 24 05:53:44 2009 New Revision: 11947 Log: Update index and FAQ staging pages. Modified: public_html/staging/faq.shtml public_html/staging/index.shtml Modified: public_html/staging/faq.shtml ============================================================================== --- public_html/staging/faq.shtml (original) +++ public_html/staging/faq.shtml Sun May 24 05:53:44 2009 @@ -26,7 +26,8 @@
    1. General
        -
      1. abcl
        2. +
      2. What license is used for ABCL?
        3. +
      3. How/Where should I report bugs?
    @@ -37,12 +38,30 @@

    General

    -
    -

    abcl

    +
    +

    What license is used for ABCL?

    +

    ABCL is distributed under the GNU General Public License with Classpath +exception. This is the same license as used for JAVA SE and GNU Classpath.

    + +

    Basically this means you can use ABCL from your application without the +need to make your own application open source.

    +
    +

    How/Where should I report bugs?

    + +

    There is a list of currently known problems (bugs) in our +bug tracker. +Unfortunately, due to spamming problems, administration of bugs has been +closed for anybody but common-lisp.net members.

    + +

    If you found a bug which is not on the list, or you want to stress +the importance of one that is, please mail our mailing list about it.

    +
    Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sun May 24 05:53:44 2009 @@ -25,7 +25,7 @@ - - + + - - + +
    Project description
    ABCL is a full implementation of the Common Lisp language - featuring both an interpreter and a compiler, running in the JVM. Originally + featuring both an interpreter and a compiler, running in the JVM. Originally started to be a scripting language for the J editor, it now supports JSR-233 (Java scripting API): it can be a scripting engine in any Java application. Additionally, it can be used to implement (parts of) the application @@ -44,7 +44,7 @@
  • Introduction: building & running
  • Documentation
    • -
  • Examples
    • +
  • Examples
  • Testimonials
  • Bug reporting
    • @@ -111,16 +111,6 @@ compiler that compiles Lisp source to JVM bytecode, and an interactive REPL for program development.

    - ABCL is distributed under the terms of the GNU General Public - License, with a special linking exception. If you link ABCL with your - own program, then you do not need to release the source code for that - program. However, any changes that you make to ABCL itself must be - released in accordance with the terms of the GPL. The license is the - same as used by GNU Classpath and J2SE (Java). -

    - ABCL runs on platforms that support Java 1.5 (or later), including Linux, - Windows, Mac OS X and the BSD family. -

    ABCL is free software and comes with ABSOLUTELY NO WARRANTY.

    The latest version is 0.15.0, released June ??, 2009. @@ -128,17 +118,6 @@

    - Examples -

    -
    -
    - In the source repository there are - examples - on how to integrate the Lisp environment with your Java code, - showing you how to call back and forth between the two.
    -
    -
    -

    Repository

    From vvoutilainen at common-lisp.net Sun May 24 09:59:14 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 24 May 2009 05:59:14 -0400 Subject: [armedbear-cvs] r11948 - public_html/staging Message-ID: Author: vvoutilainen Date: Sun May 24 05:59:11 2009 New Revision: 11948 Log: Mailing list link for bug reporting faq. Modified: public_html/staging/faq.shtml Modified: public_html/staging/faq.shtml ============================================================================== --- public_html/staging/faq.shtml (original) +++ public_html/staging/faq.shtml Sun May 24 05:59:11 2009 @@ -60,7 +60,7 @@ closed for anybody but common-lisp.net members.

    If you found a bug which is not on the list, or you want to stress -the importance of one that is, please mail our mailing list about it.

    +the importance of one that is, please mail our mailing list about it.

    From ehuelsmann at common-lisp.net Sun May 24 12:10:17 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 24 May 2009 08:10:17 -0400 Subject: [armedbear-cvs] r11949 - public_html/staging Message-ID: Author: ehuelsmann Date: Sun May 24 08:09:53 2009 New Revision: 11949 Log: Move more from the front page to the FAQ. Update the headers. Modified: public_html/staging/contributing.shtml public_html/staging/faq.shtml public_html/staging/index.shtml Modified: public_html/staging/contributing.shtml ============================================================================== --- public_html/staging/contributing.shtml (original) +++ public_html/staging/contributing.shtml Sun May 24 08:09:53 2009 @@ -6,12 +6,6 @@ Contributing: Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM - @@ -22,6 +16,8 @@
    + +
    Modified: public_html/staging/faq.shtml ============================================================================== --- public_html/staging/faq.shtml (original) +++ public_html/staging/faq.shtml Sun May 24 08:09:53 2009 @@ -3,20 +3,14 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> - FAQ: Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM + FAQ: ABCL - Common Lisp on the JVM -
    -

    FAQ: Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM

    +

    FAQ: ABCL - Common Lisp on the JVM

    @@ -26,17 +20,37 @@
    1. General
        +
      1. What is ABCL?
      2. What license is used for ABCL?
      3. How/Where should I report bugs?
        4. +
      4. Is ABCL faster or slower than implementation XYZ?
        5. +
      5. What is the quality of the implementation? How can you tell?
    -

    General

    +
    +

    What is ABCL?

    +

    ABCL is an implementation of the full Common Lisp specification, with +the exception of the implementation of the long form of +DEFINE-METHOD-COMBINATION.

    + +

    Unfortunately, the CLOS implementation is not accessible through +a MOP (MetaObject Protocol). Any contributions in this area would +be greatly appreciated, ofcourse.

    + +

    One thing which is considered almost standard lisp - because all +implementations deliver it - is "Gray streams". Unfortunately ABCLs +version is broken [as per 05/2009]. It should be noted this is by no +means the final state of affairs, though, merely a warning that one +can't depend on this feature at the moment.

    + +
    +

    What license is used for ABCL?

    @@ -60,12 +74,67 @@ closed for anybody but common-lisp.net members.

    If you found a bug which is not on the list, or you want to stress -the importance of one that is, please mail our mailing list about it.

    +the importance of one that is, please mail our mailing list about it.

    + +
    +

    Is ABCL faster or slower than implementation XYZ?

    + +

    General comparisons are hard to make, the relative speeds depend +on a lot of factors. For example timing outcomes of specific bits +of Java may have different timings depending on the settings of +the HotSpot JIT compiler (if the tests are run on Sun).

    + +

    Some statements can be made in general though. Due to the fact that +ABCL has been implemented in Java, it inherits some of the aspects of +Java itself as well as the fact that it can't directly manipulate +CPU content. Implementations such as SBCL and Closure CL can do that and +take that to their advantage: for example in SBCL a boxed fixnum is a +direct register value, while in ABCL it's encapsulated in an object.

    + +

    On the other hand, ABCL - like SBCL - supports unboxed fixnums. ABCL's +fixnums support the full 32 bit range of integer values, while SBCL due +to its boxing strategy can only use 29 bit integers (on 32bit platforms).

    + +

    Given ABCL's age - a young project by Lisp standards - there is also +plenty of room for improvement in the area of execution speed and optimization. +The project welcomes initiatives to improve performance.

    +
    +
    +

    What is the quality of the implementation? How can you tell?

    + +

    The project recognises there are several dimensions to quality:

    +
      +
    1. The level of compliance to the standard
      2. +
    2. The level of 'useability': whether (or not) the application is able + to run existing Lisp code
      3. +
    + +

    The plan is to add to the list above software from Edi Weitz, who + wrote some great libraries.

    + +

    The first item is being measured by running the ANSI test suite compliance + tests. The second item is measured by compiling and running the test suite + in the Maxima application. + Additionally, compilation of AP5 is used to + improve this measure too.

    + +

    ABCL 0.15.0 fails 34 out of 21702 tests in the ANSI test suite + in interpreted and compiled modes, coming from ca 44 in the last + release.

    +

    As a measure of 'improvement achieved', the development team refers + to the number of failing tests in the Maxima test suite too. + ABCL 0.15.0 is able to run the test suite with 'only' ca 75 failing + tests, coming from ca 1400 failures around October 2008.

    + +
    + +
    @@ -76,5 +145,6 @@
    $Id$
    + Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sun May 24 08:09:53 2009 @@ -142,25 +142,12 @@ quality of ABCL being good enough for their needs though. Check the testimonials page for their own words.

    - ABCL 0.15.0 fails 34 out of 21702 tests in the ANSI test suite - in interpreted and compiled modes, coming from ca 44 in the last - release. - As a measure of 'improvement achieved', the development team refers - to the number of failing tests in the Maxima test suite too. - ABCL 0.15.0 is able to run the test suite with 'only' ca 75 failing - tests, coming from ca 1400 failures around october 2008. -

    ABCL's CLOS is slow and does not handle on-the-fly redefinition of classes correctly. There is no support for the long form of DEFINE-METHOD-COMBINATION, and certain other required CLOS features are also missing. Enough CLOS is there to run ASDF and CL-PPCRE, if you're in no hurry. There's no MOP worth mentioning.

    - Due to the age of the source code (when compared to several other - implementations) you're more likely to find bugs in ABCL. However, - we're committed to fixing any bugs you find. Patches (bugfixes as - well as features) are most welcome. -

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

    From ehuelsmann at common-lisp.net Sun May 24 12:28:24 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 24 May 2009 08:28:24 -0400 Subject: [armedbear-cvs] r11950 - public_html/staging Message-ID: Author: ehuelsmann Date: Sun May 24 08:28:11 2009 New Revision: 11950 Log: Remove index.shtml sections which are now addressed elsewhere. Update the layout of index.shtml now that I saw what others see. Modified: public_html/staging/index.shtml public_html/staging/style.css Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sun May 24 08:28:11 2009 @@ -34,8 +34,10 @@
    Download your copy from SourceForge: 0.15.0 (zip)
    Users (development with ABCL)Developers (development of ABCL) Users + (development with ABCL)Developers + (development of ABCL)
    @@ -72,8 +74,8 @@
    System requirements (Users)System requirements (Developers) System requirements (Users)System requirements (Developers)
    @@ -102,22 +104,6 @@

    - About ABCL -

    -
    -
    - Armed Bear Common Lisp (ABCL) is an implementation of ANSI Common Lisp - that runs in a Java virtual machine. It provides a runtime system, a - compiler that compiles Lisp source to JVM bytecode, and an interactive - REPL for program development. -

    - ABCL is free software and comes with ABSOLUTELY NO WARRANTY. -

    - The latest version is 0.15.0, released June ??, 2009. -
    -
    - -

    Repository

    @@ -132,37 +118,6 @@

    - Bugs -

    -
    -
    - ABCL is a young implementation (particularly by Lisp standards). - Even though a lot of energy is spent resolving issues, you may - well encounter bugs. A number of people have testified to the - quality of ABCL being good enough for their needs though. Check - the testimonials page for their own words. -

    - ABCL's CLOS is slow and does not handle on-the-fly - redefinition of classes correctly. There is no support for the long - form of DEFINE-METHOD-COMBINATION, and certain other required CLOS - features are also missing. Enough CLOS is there to run ASDF and - CL-PPCRE, if you're in no hurry. There's no MOP worth mentioning. -

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

    -
    -
    The project is using several ways to test standards compliance as well - as practical applicability of ABCL by using these projects' test suites - as 'compliance' indicators: -
      -
    • ANSI Common Lisp compliance tests
      • -
    • Maxima - Computer algebra system
      • -
    • AP5 - see http://ap5.com/
      • -
    -
    -
    - -

    Installation

    Modified: public_html/staging/style.css ============================================================================== --- public_html/staging/style.css (original) +++ public_html/staging/style.css Sun May 24 08:28:11 2009 @@ -54,7 +54,13 @@ text-decoration:underline; } .summary-header { + font-size: 120%; font-weight: bold; color: white; background-color: #369; - text-align: center } \ No newline at end of file + text-align: center } + +.summary-header span { + font-weight: normal; + font-size: 80%; +} \ No newline at end of file From astalla at common-lisp.net Mon May 25 20:54:04 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 25 May 2009 16:54:04 -0400 Subject: [armedbear-cvs] r11951 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon May 25 16:53:53 2009 New Revision: 11951 Log: Fixed javaInstance() from r11834: the arguments for isAssignableFrom were in the wrong order. (obj.javaInstance(class) is used by abcl to check whether "obj" is an instance of "class"). Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Mon May 25 16:53:53 2009 @@ -106,7 +106,7 @@ public Object javaInstance(Class c) throws ConditionThrowable { - if (getClass().isAssignableFrom(c)) + if (c.isAssignableFrom(getClass())) return this; return error(new LispError("The value " + writeToString() + " is not of class " + c.getName())); From vvoutilainen at common-lisp.net Tue May 26 18:02:12 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 26 May 2009 14:02:12 -0400 Subject: [armedbear-cvs] r11952 - public_html/staging Message-ID: Author: vvoutilainen Date: Tue May 26 14:02:03 2009 New Revision: 11952 Log: Patching guide. Modified: public_html/staging/contributing.shtml Modified: public_html/staging/contributing.shtml ============================================================================== --- public_html/staging/contributing.shtml (original) +++ public_html/staging/contributing.shtml Tue May 26 14:02:03 2009 @@ -5,7 +5,7 @@ Contributing: Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM - + -equiv="Content-Type" content="text/html; charset=ISO-8859-1"/> @@ -29,5 +29,46 @@
    $Id$
    + +
    +

    A quick guide to producing patches for ABCL

    + +This guide describes how to contribute patches to ABCL, while making +sure that the patch doesn't introduce regressions. + +
      +
    1. Build abcl and run the ansi-tests with the pristine tree before making patches + and store the test results. Invoke the following commands from the + abcl main directory: + +
      ant abcl.clean +
      ant abcl.wrapper +
      ant test.ansi.interpreted +
      ant test.ansi.compiled +       +
      The test runs will report where their logs are written, keep those + files at hand for comparing them with later runs with modified code. +
      2. +
    2. + Develop your patch. +
      3. +
    3. + Build abcl and run the ansi-tests with your modification and store the test results. + The commands are as in the first step. +
      4. +
    4. + Compare the new test results with the pristine results, if there are no + additional failures, the patch should be ok. Example comparison for + linux would be + +
      diff -u abcl-test-20093726-2037.log abcl-test-20094426-2044.log +       +
      Note that the file names are generated dynamically by the test runs. + The list of failed tests can be found at the end of the log, so that's + practically the only thing you're interested in. If the lists don't + differ, you've successfully created a patch with no ansi-test regressions. +
      5. +
    +
    From vvoutilainen at common-lisp.net Tue May 26 18:08:40 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 26 May 2009 14:08:40 -0400 Subject: [armedbear-cvs] r11953 - public_html/staging Message-ID: Author: vvoutilainen Date: Tue May 26 14:08:33 2009 New Revision: 11953 Log: Fix breakage. Modified: public_html/staging/contributing.shtml Modified: public_html/staging/contributing.shtml ============================================================================== --- public_html/staging/contributing.shtml (original) +++ public_html/staging/contributing.shtml Tue May 26 14:08:33 2009 @@ -5,7 +5,7 @@ Contributing: Armed Bear Common Lisp (ABCL) - Common Lisp on the JVM - -equiv="Content-Type" content="text/html; charset=ISO-8859-1"/> + From ehuelsmann at common-lisp.net Tue May 26 18:34:43 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 26 May 2009 14:34:43 -0400 Subject: [armedbear-cvs] r11954 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 26 14:34:23 2009 New Revision: 11954 Log: Remove workaround for the fact that Math.hypot() was added in Java 1.5: We require 1.5 and hence don't need to work around it. Modified: trunk/abcl/src/org/armedbear/lisp/Complex.java Modified: trunk/abcl/src/org/armedbear/lisp/Complex.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Complex.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Complex.java Tue May 26 14:34:23 2009 @@ -33,8 +33,6 @@ package org.armedbear.lisp; -import java.lang.reflect.Method; - public final class Complex extends LispObject { public final LispObject realpart; @@ -302,15 +300,6 @@ return !isEqualTo(obj); } - private static Method hypotMethod = null; - static { try { - hypotMethod = - Class.forName("java.lang.Math") - .getMethod("hypot", new Class[] { Double.TYPE, Double.TYPE }); - } - catch (Throwable t) { Debug.trace(t); } - } - @Override public LispObject ABS() throws ConditionThrowable { @@ -318,31 +307,10 @@ return imagpart.ABS(); double real = DoubleFloat.coerceToFloat(realpart).value; double imag = DoubleFloat.coerceToFloat(imagpart).value; - try - { - if (hypotMethod != null) - { - Object[] args; - args = new Object[2]; - args[0] = new Double(real); - args[1] = new Double(imag); - Double d = (Double) hypotMethod.invoke(null, args); - if (realpart instanceof DoubleFloat) - return new DoubleFloat(d.doubleValue()); - else - return new SingleFloat((float)d.doubleValue()); - } - } - catch (Throwable t) - { - Debug.trace(t); - // Fall through... - } - double result = Math.sqrt(real * real + imag * imag); if (realpart instanceof DoubleFloat) - return new DoubleFloat(result); + return new DoubleFloat(Math.hypot(real, imag)); else - return new SingleFloat((float)result); + return new SingleFloat((float)Math.hypot(real, imag)); } @Override From ehuelsmann at common-lisp.net Tue May 26 18:59:31 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 26 May 2009 14:59:31 -0400 Subject: [armedbear-cvs] r11955 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: ehuelsmann Date: Tue May 26 14:59:27 2009 New Revision: 11955 Log: Fix some failures in ABCL's own test suite; some by fixing the expected output. Modified: trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java trunk/abcl/src/org/armedbear/lisp/MathFunctions.java trunk/abcl/src/org/armedbear/lisp/SingleFloat.java trunk/abcl/test/lisp/abcl/math-tests.lisp Modified: trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java (original) +++ trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java Tue May 26 14:59:27 2009 @@ -484,6 +484,8 @@ final LispThread thread = LispThread.currentThread(); double divisor = ((SingleFloat)obj).value; double quotient = value / divisor; + if (value != 0) + MathFunctions.OverUnderFlowCheck(quotient); if (quotient >= Integer.MIN_VALUE && quotient <= Integer.MAX_VALUE) { int q = (int) quotient; return thread.setValues(Fixnum.getInstance(q), @@ -516,6 +518,8 @@ double divisor = ((DoubleFloat)obj).value; // Debug.trace("divisor = " + divisor); double quotient = value / divisor; + if (value != 0) + MathFunctions.OverUnderFlowCheck(quotient); // Debug.trace("quotient = " + quotient); if (quotient >= Integer.MIN_VALUE && quotient <= Integer.MAX_VALUE) { int q = (int) quotient; Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MathFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Tue May 26 14:59:27 2009 @@ -771,6 +771,45 @@ return number; } + /** Checks number for over- or underflow values. + * + * @param number + * @return number or signals an appropriate error + * @throws org.armedbear.lisp.ConditionThrowable + */ + final static float OverUnderFlowCheck(float number) + throws ConditionThrowable + { + if (TRAP_OVERFLOW) { + if (Float.isInfinite(number)) + error(new FloatingPointOverflow(NIL)); + } + if (TRAP_UNDERFLOW) { + if (number == 0) + error(new FloatingPointUnderflow(NIL)); + } + return number; + } + + /** Checks number for over- or underflow values. + * + * @param number + * @return number or signals an appropriate error + * @throws org.armedbear.lisp.ConditionThrowable + */ + public final static double OverUnderFlowCheck(double number) + throws ConditionThrowable + { + if (TRAP_OVERFLOW) { + if (Double.isInfinite(number)) + error(new FloatingPointOverflow(NIL)); + } + if (TRAP_UNDERFLOW) { + if (number == 0) + error(new FloatingPointUnderflow(NIL)); + } + return number; + } // Adapted from SBCL. /** Return the exponent of base taken to the integer exponent power * Modified: trunk/abcl/src/org/armedbear/lisp/SingleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SingleFloat.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Tue May 26 14:59:27 2009 @@ -489,6 +489,8 @@ final LispThread thread = LispThread.currentThread(); float divisor = ((SingleFloat)obj).value; float quotient = value / divisor; + if (value != 0) + MathFunctions.OverUnderFlowCheck(quotient); if (quotient >= Integer.MIN_VALUE && quotient <= Integer.MAX_VALUE) { int q = (int) quotient; return thread.setValues(Fixnum.getInstance(q), @@ -519,6 +521,8 @@ final LispThread thread = LispThread.currentThread(); double divisor = ((DoubleFloat)obj).value; double quotient = value / divisor; + if (value != 0) + MathFunctions.OverUnderFlowCheck(quotient); if (quotient >= Integer.MIN_VALUE && quotient <= Integer.MAX_VALUE) { int q = (int) quotient; return thread.setValues(Fixnum.getInstance(q), Modified: trunk/abcl/test/lisp/abcl/math-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/math-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/math-tests.lisp Tue May 26 14:59:27 2009 @@ -305,8 +305,8 @@ (deftest expt.15 (expt 1 1/2) - #+clisp 1 - #-clisp 1.0) + #+(or clisp abcl) 1 + #-(or clisp abcl) 1.0) (deftest expt.16 (expt 9 1/2) @@ -429,11 +429,11 @@ (deftest atanh.1 (atanh 2) - #C(0.54930615 1.5707964)) + #C(0.54930615 -1.5707964)) (deftest atanh.2 (atanh -2) - #C(-0.54930615 -1.5707964)) + #C(-0.54930615 1.5707964)) (deftest truncate.1 (truncate least-positive-single-float) From ehuelsmann at common-lisp.net Tue May 26 20:46:16 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 26 May 2009 16:46:16 -0400 Subject: [armedbear-cvs] r11956 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 26 16:46:15 2009 New Revision: 11956 Log: Improved integer type derivation for MINUS - fixes some tests in ABCL's test suite. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue May 26 16:46:15 2009 @@ -6188,8 +6188,18 @@ value for use with derive-type-minus and derive-type-plus.") (define-int-bounds-derivation - (low1 high1 low2 high2) - (values (and low1 low2 (- low1 low2)) - (and high1 high2 (- high1 high2)))) + (values (when (and low1 high2) ;; low1 or high2 undefined: no lower bound + (if low2 + (min (- low1 low2) + (- low1 high2)) + ;; low2 undefined: no effect on lower bound + (- low1 high2))) + (when (and high1 low2) ;; high1 or low2 undefined: no upper bound + (if high2 + (max (- high1 low2) + (- high1 high2)) + ;; high2 undefined: no effect on upper bound + (- high1 low2))))) (defun derive-compiler-types (args op) (flet ((combine (x y) From ehuelsmann at common-lisp.net Tue May 26 20:55:33 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 26 May 2009 16:55:33 -0400 Subject: [armedbear-cvs] r11957 - public_html/staging Message-ID: Author: ehuelsmann Date: Tue May 26 16:55:31 2009 New Revision: 11957 Log: Hopefully fix layout issue. Modified: public_html/staging/contributing.shtml Modified: public_html/staging/contributing.shtml ============================================================================== --- public_html/staging/contributing.shtml (original) +++ public_html/staging/contributing.shtml Tue May 26 16:55:31 2009 @@ -18,19 +18,11 @@
    -
    -
    -
    -

    Back to Common-lisp.net.

    -
    - Valid XHTML 1.0 Strict -
    -
    $Id$
    -
    -
    + +

    A quick guide to producing patches for ABCL

    This guide describes how to contribute patches to ABCL, while making @@ -70,5 +62,15 @@
    +
    +
    +

    Back to Common-lisp.net.

    + +
    + Valid XHTML 1.0 Strict +
    +
    $Id$
    +
    + From ehuelsmann at common-lisp.net Wed May 27 06:12:48 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 27 May 2009 02:12:48 -0400 Subject: [armedbear-cvs] r11958 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 27 02:12:40 2009 New Revision: 11958 Log: Redoing my math homework: "x < y --> -x > -y" Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed May 27 02:12:40 2009 @@ -6188,18 +6188,8 @@ value for use with derive-type-minus and derive-type-plus.") (define-int-bounds-derivation - (low1 high1 low2 high2) - (values (when (and low1 high2) ;; low1 or high2 undefined: no lower bound - (if low2 - (min (- low1 low2) - (- low1 high2)) - ;; low2 undefined: no effect on lower bound - (- low1 high2))) - (when (and high1 low2) ;; high1 or low2 undefined: no upper bound - (if high2 - (max (- high1 low2) - (- high1 high2)) - ;; high2 undefined: no effect on upper bound - (- high1 low2))))) + (values (and low1 high2 (- low1 high2)) + (and high1 low2 (- high2 low2)))) (defun derive-compiler-types (args op) (flet ((combine (x y) From ehuelsmann at common-lisp.net Wed May 27 18:51:52 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 27 May 2009 14:51:52 -0400 Subject: [armedbear-cvs] r11959 - branches/0.15.x Message-ID: Author: ehuelsmann Date: Wed May 27 14:51:42 2009 New Revision: 11959 Log: Create 0.15.x stabilization branch. Added: branches/0.15.x/ - copied from r11958, /trunk/ From ehuelsmann at common-lisp.net Wed May 27 18:53:18 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 27 May 2009 14:53:18 -0400 Subject: [armedbear-cvs] r11960 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 27 14:53:06 2009 New Revision: 11960 Log: With 0.15 branched, increase trunk version number. Modified: trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Wed May 27 14:53:06 2009 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.15.0-dev"; + return "0.16.0-dev"; } } From ehuelsmann at common-lisp.net Wed May 27 19:51:13 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 27 May 2009 15:51:13 -0400 Subject: [armedbear-cvs] r11961 - trunk/abcl/scripts Message-ID: Author: ehuelsmann Date: Wed May 27 15:51:11 2009 New Revision: 11961 Log: Delete empty scripts/ folder with unknown purpose. Removed: trunk/abcl/scripts/ From ehuelsmann at common-lisp.net Fri May 29 06:08:36 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 29 May 2009 02:08:36 -0400 Subject: [armedbear-cvs] r11962 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 29 02:08:26 2009 New Revision: 11962 Log: Revert r11958: it breaks a number of ANSI tests. Found by: Peter Tsenter (ptsenter at hotmail) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 29 02:08:26 2009 @@ -6188,8 +6188,18 @@ value for use with derive-type-minus and derive-type-plus.") (define-int-bounds-derivation - (low1 high1 low2 high2) - (values (and low1 high2 (- low1 high2)) - (and high1 low2 (- high2 low2)))) + (values (when (and low1 high2) ;; low1 or high2 undefined: no lower bound + (if low2 + (min (- low1 low2) + (- low1 high2)) + ;; low2 undefined: no effect on lower bound + (- low1 high2))) + (when (and high1 low2) ;; high1 or low2 undefined: no upper bound + (if high2 + (max (- high1 low2) + (- high1 high2)) + ;; high2 undefined: no effect on upper bound + (- high1 low2))))) (defun derive-compiler-types (args op) (flet ((combine (x y) From ehuelsmann at common-lisp.net Fri May 29 06:15:01 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 29 May 2009 02:15:01 -0400 Subject: [armedbear-cvs] r11963 - branches/0.15.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri May 29 02:14:57 2009 New Revision: 11963 Log: Backport r11962 (reversal of r11958). Modified: branches/0.15.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/0.15.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/0.15.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/0.15.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 29 02:14:57 2009 @@ -6188,8 +6188,18 @@ value for use with derive-type-minus and derive-type-plus.") (define-int-bounds-derivation - (low1 high1 low2 high2) - (values (and low1 high2 (- low1 high2)) - (and high1 low2 (- high2 low2)))) + (values (when (and low1 high2) ;; low1 or high2 undefined: no lower bound + (if low2 + (min (- low1 low2) + (- low1 high2)) + ;; low2 undefined: no effect on lower bound + (- low1 high2))) + (when (and high1 low2) ;; high1 or low2 undefined: no upper bound + (if high2 + (max (- high1 low2) + (- high1 high2)) + ;; high2 undefined: no effect on upper bound + (- high1 low2))))) (defun derive-compiler-types (args op) (flet ((combine (x y) From vvoutilainen at common-lisp.net Sat May 30 20:03:02 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 30 May 2009 16:03:02 -0400 Subject: [armedbear-cvs] r11964 - public_html/staging Message-ID: Author: vvoutilainen Date: Sat May 30 16:02:52 2009 New Revision: 11964 Log: Some license elaboration. Modified: public_html/staging/faq.shtml Modified: public_html/staging/faq.shtml ============================================================================== --- public_html/staging/faq.shtml (original) +++ public_html/staging/faq.shtml Sat May 30 16:02:52 2009 @@ -63,6 +63,22 @@

    Basically this means you can use ABCL from your application without the need to make your own application open source.

    +

    +In general, such usage means that whenever you keep ABCL as a separate +jar file, you won't have licensing problems. The combining in the +Classpath exception means that you can + +

      +
    1. Extend ABCL java classes in your program
      2. +
    2. Use ABCL java classes in your program
      3. +
    3. Invoke ABCL lisp functions in your program
      4. +
    + +without having to worry about the licensing. You do have to +distribute the source code of ABCL (including modifications) +if you distribute ABCL, but otherwise the license of ABCL is not viral. +

    +
    From vvoutilainen at common-lisp.net Sat May 30 20:18:22 2009 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 30 May 2009 16:18:22 -0400 Subject: [armedbear-cvs] r11965 - public_html/staging Message-ID: Author: vvoutilainen Date: Sat May 30 16:18:20 2009 New Revision: 11965 Log: Mention gmane access. Modified: public_html/staging/index.shtml Modified: public_html/staging/index.shtml ============================================================================== --- public_html/staging/index.shtml (original) +++ public_html/staging/index.shtml Sat May 30 16:18:20 2009 @@ -54,6 +54,7 @@
    • Mailing list
      • +
    • Mailing list access on gmane
    • Repository
    • Technical wiki
    • Bug tracker
      • From ehuelsmann at common-lisp.net Sun May 31 09:57:29 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 31 May 2009 05:57:29 -0400 Subject: [armedbear-cvs] r11966 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 31 05:57:18 2009 New Revision: 11966 Log: Symbol execute() methods: change to a different pattern to reduce relative share in execution time of loading our system (roughly -50%). Also, when integrating with Java, randomly catching exceptions and converting them to Lisp errors doesn't really work well. Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sun May 31 05:57:18 2009 @@ -714,172 +714,141 @@ } @Override - public LispObject execute() throws ConditionThrowable + final public LispObject execute() throws ConditionThrowable { - try - { - return function.execute(); - } - catch (NullPointerException e) - { - return handleNPE(e, NIL); - } + LispObject fun; + if ((fun = function) == null) + return undefinedFunction(NIL); + + return fun.execute(); } @Override - public LispObject execute(LispObject arg) throws ConditionThrowable + final public LispObject execute(LispObject arg) throws ConditionThrowable { - try - { - return function.execute(arg); - } - catch (NullPointerException e) - { - return handleNPE(e, list(arg)); - } + LispObject fun; + if ((fun = function) == null) + return undefinedFunction(list(arg)); + + return fun.execute(arg); } @Override - public LispObject execute(LispObject first, LispObject second) + final public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { - try - { - return function.execute(first, second); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second)); - } + LispObject fun; + if ((fun = function) == null) + return undefinedFunction(list(first, second)); + + return fun.execute(first, second); } @Override - public LispObject execute(LispObject first, LispObject second, + final public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable { - try - { - return function.execute(first, second, third); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second, third)); - } + LispObject fun; + if ((fun = function) == null) + return undefinedFunction(list(first, second, third)); + + return fun.execute(first, second, third); } @Override - public LispObject execute(LispObject first, LispObject second, + final public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable { - try - { - return function.execute(first, second, third, fourth); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second, third, fourth)); - } + LispObject fun; + if ((fun = function) == null) + return undefinedFunction(list(first, second, third, fourth)); + + return fun.execute(first, second, third, fourth); } @Override - public LispObject execute(LispObject first, LispObject second, + final public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) throws ConditionThrowable { - try - { - return function.execute(first, second, third, fourth, fifth); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second, third, fourth, fifth)); - } + LispObject fun; + if ((fun = function) == null) + return undefinedFunction(list(first, second, third, fourth, + fifth)); + + return fun.execute(first, second, third, fourth, + fifth); } @Override - public LispObject execute(LispObject first, LispObject second, + final public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) throws ConditionThrowable { - try - { - return function.execute(first, second, third, fourth, fifth, sixth); - } - catch (NullPointerException e) - { - return handleNPE(e, list(first, second, third, fourth, fifth, - sixth)); - } + LispObject fun; + if ((fun = function) == null) + return undefinedFunction(list(first, second, third, fourth, + fifth, sixth)); + + return fun.execute(first, second, third, fourth, + fifth, sixth); } @Override - public LispObject execute(LispObject first, LispObject second, + final public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh) throws ConditionThrowable { - try - { - return function.execute(first, second, third, fourth, fifth, sixth, - seventh); - } - catch (NullPointerException e) - { - return handleNPE(e, - list(first, second, third, fourth, fifth, sixth, - seventh)); - } + LispObject fun; + if ((fun = function) == null) + return undefinedFunction(list(first, second, third, fourth, + fifth, sixth, seventh)); + + return fun.execute(first, second, third, fourth, + fifth, sixth, seventh); } @Override - public LispObject execute(LispObject first, LispObject second, + final public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh, LispObject eighth) throws ConditionThrowable { - try - { - return function.execute(first, second, third, fourth, fifth, sixth, - seventh, eighth); - } - catch (NullPointerException e) - { - return handleNPE(e, - list(first, second, third, fourth, fifth, sixth, - seventh, eighth)); - } + LispObject fun; + if ((fun = function) == null) + return undefinedFunction(list(first, second, third, fourth, + fifth, sixth, seventh, eighth)); + + return fun.execute(first, second, third, fourth, + fifth, sixth, seventh, eighth); } @Override - public LispObject execute(LispObject[] args) throws ConditionThrowable + final public LispObject execute(LispObject[] args) throws ConditionThrowable { - try - { - return function.execute(args); - } - catch (NullPointerException e) - { + LispObject fun; + if ((fun = function) == null) { LispObject list = NIL; for (int i = args.length; i-- > 0;) list = new Cons(args[i], list); - return handleNPE(e, list); - } + return undefinedFunction(list); + } + + return fun.execute(args); } - private final LispObject handleNPE(NullPointerException e, LispObject args) + private final LispObject undefinedFunction(LispObject args) throws ConditionThrowable { - if (function == null) - return LispThread.currentThread().execute(Symbol.UNDEFINED_FUNCTION_CALLED, - this, args); - Debug.trace(e); - return error(new LispError("Null pointer exception")); + return LispThread.currentThread().execute(Symbol.UNDEFINED_FUNCTION_CALLED, + this, args); } @Override From ehuelsmann at common-lisp.net Sun May 31 11:36:00 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 31 May 2009 07:36:00 -0400 Subject: [armedbear-cvs] r11967 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 31 07:35:53 2009 New Revision: 11967 Log: Fix the wrong thread being reported as the current one. Note: The error being fixed is that a new LispThread was created, regardless of whether there was an initiating LispThread already. Found by: Tobias Rittweiler (tcr in #lisp) 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 Sun May 31 07:35:53 2009 @@ -49,9 +49,12 @@ @Override public LispThread initialValue() { Thread thisThread = Thread.currentThread(); - LispThread newThread = new LispThread(thisThread); - LispThread.map.put(thisThread,newThread); - return newThread; + LispThread thread = LispThread.map.get(thisThread); + if (thread == null) { + thread = new LispThread(thisThread); + LispThread.map.put(thisThread,thread); + } + return thread; } }; @@ -60,7 +63,7 @@ return threads.get(); } - private final Thread javaThread; + private final Thread javaThread; private boolean destroyed; private final LispObject name; public SpecialBinding lastSpecialBinding; @@ -103,6 +106,7 @@ }; javaThread = new Thread(r); this.name = name; + map.put(javaThread, this); javaThread.setDaemon(true); javaThread.start(); } From ehuelsmann at common-lisp.net Sun May 31 15:17:26 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 31 May 2009 11:17:26 -0400 Subject: [armedbear-cvs] r11968 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 31 11:17:24 2009 New Revision: 11968 Log: More type assertion functions (checkXXXX()). 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 May 31 11:17:24 2009 @@ -845,6 +845,25 @@ type_error(obj, Symbol.VECTOR); } + public static final DoubleFloat checkDoubleFloat(LispObject obj) + throws ConditionThrowable + { + if (obj instanceof DoubleFloat) + return (DoubleFloat) obj; + return (DoubleFloat)// Not reached. + type_error(obj, Symbol.DOUBLE_FLOAT); + } + + public static final SingleFloat checkSingleFloat(LispObject obj) + throws ConditionThrowable + { + if (obj instanceof SingleFloat) + return (SingleFloat) obj; + return (SingleFloat)// Not reached. + type_error(obj, Symbol.SINGLE_FLOAT); + } + + static { // ### *gensym-counter* From ehuelsmann at common-lisp.net Sun May 31 15:19:04 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 31 May 2009 11:19:04 -0400 Subject: [armedbear-cvs] r11969 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 31 11:19:00 2009 New Revision: 11969 Log: Factor out the lisp->Java sleep interval conversion routine. Also clarify the code by using a type assertion instead of a direct class cast. Requested by tcr (from #lisp) for his work on SLIME & ABCL. 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 Sun May 31 11:19:00 2009 @@ -1062,19 +1062,26 @@ } }; + public static final long javaSleepInterval(LispObject lispSleep) + throws ConditionThrowable + { + double d = + checkDoubleFloat(lispSleep.multiplyBy(new DoubleFloat(1000))).getValue(); + if (d < 0) + type_error(lispSleep, list(Symbol.REAL, Fixnum.ZERO)); + + return (d < Long.MAX_VALUE ? (long) d : Long.MAX_VALUE); + } + // ### sleep private static final Primitive SLEEP = new Primitive("sleep", "seconds") { @Override public LispObject execute(LispObject arg) throws ConditionThrowable { - double d = - ((DoubleFloat)arg.multiplyBy(new DoubleFloat(1000))).getValue(); - if (d < 0) - return type_error(arg, list(Symbol.REAL, Fixnum.ZERO)); - long millis = d < Long.MAX_VALUE ? (long) d : Long.MAX_VALUE; + try { - Thread.sleep(millis); + Thread.sleep(javaSleepInterval(arg)); } catch (InterruptedException e) { currentThread().processThreadInterrupts(); From ehuelsmann at common-lisp.net Sun May 31 17:01:11 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 31 May 2009 13:01:11 -0400 Subject: [armedbear-cvs] r11970 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Sun May 31 13:01:08 2009 New Revision: 11970 Log: Performance improvement by removing fcn.size() calls; also lots of reindenting (for some reason I'm seeing lots of bad indentation in NetBeans; my config?). Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Sun May 31 13:01:08 2009 @@ -59,24 +59,24 @@ super(null); } - private byte[] read_buf = new byte[1]; + private byte[] read_buf = new byte[1]; @Override - public int read() throws IOException { - int len = read(read_buf); - if (len == 1) { - // byte is signed, char is unsigned, int is signed. - // buf can hold 0xff, we want it as 0xff in int, not -1. - return 0xff & (int) read_buf[0]; - } else { - return -1; - } - } + public int read() throws IOException { + int len = read(read_buf); + if (len == 1) { + // byte is signed, char is unsigned, int is signed. + // buf can hold 0xff, we want it as 0xff in int, not -1. + return 0xff & (int) read_buf[0]; + } else { + return -1; + } + } - @Override + @Override public int read(byte[] b, int off, int len) throws IOException { - return RandomAccessCharacterFile.this.read(b, off, len); - } + return RandomAccessCharacterFile.this.read(b, off, len); + } @Override public void unread(int b) throws IOException { @@ -125,37 +125,37 @@ return this.read(b, 0, b.length); } - @Override - public void close() throws IOException { - RandomAccessCharacterFile.this.close(); - } + @Override + public void close() throws IOException { + RandomAccessCharacterFile.this.close(); + } } private class RandomAccessOutputStream extends OutputStream { - private RandomAccessOutputStream() { - } + private RandomAccessOutputStream() { + } + + private byte[] buf = new byte[1]; + public void write(int b) throws IOException { + buf[0] = (byte)b; + write(buf); + } + + @Override + public void write(byte[] b, int off, int len) throws IOException { + RandomAccessCharacterFile.this.write(b, off, len); + } + + @Override + public void flush() throws IOException { + RandomAccessCharacterFile.this.flush(); + } - private byte[] buf = new byte[1]; - public void write(int b) throws IOException { - buf[0] = (byte)b; - write(buf); - } - - @Override - public void write(byte[] b, int off, int len) throws IOException { - RandomAccessCharacterFile.this.write(b, off, len); - } - - @Override - public void flush() throws IOException { - RandomAccessCharacterFile.this.flush(); - } - - @Override - public void close() throws IOException { - RandomAccessCharacterFile.this.close(); - } + @Override + public void close() throws IOException { + RandomAccessCharacterFile.this.close(); + } } // dummy reader which we need to call the Pushback constructor @@ -164,16 +164,16 @@ private class RandomAccessReader extends PushbackReader { - private RandomAccessReader() { - // because we override all methods of Pushbackreader, - // staticReader will never be referenced - super(staticReader); - } + private RandomAccessReader() { + // because we override all methods of Pushbackreader, + // staticReader will never be referenced + super(staticReader); + } - @Override - public void close() throws IOException { - RandomAccessCharacterFile.this.close(); - } + @Override + public void close() throws IOException { + RandomAccessCharacterFile.this.close(); + } private char[] read_buf = new char[1]; @@ -214,31 +214,29 @@ return RandomAccessCharacterFile.this.read(cbuf, 0, cbuf.length); } - - - @Override - public int read(char[] cb, int off, int len) throws IOException { - return RandomAccessCharacterFile.this.read(cb, off, len); - } + @Override + public int read(char[] cb, int off, int len) throws IOException { + return RandomAccessCharacterFile.this.read(cb, off, len); + } } private class RandomAccessWriter extends Writer { - private RandomAccessWriter() { - } + private RandomAccessWriter() { + } - public void close() throws IOException { - RandomAccessCharacterFile.this.close(); - } - - public void flush() throws IOException { - RandomAccessCharacterFile.this.flush(); - } - - @Override - public void write(char[] cb, int off, int len) throws IOException { - RandomAccessCharacterFile.this.write(cb, off, len); - } + public void close() throws IOException { + RandomAccessCharacterFile.this.close(); + } + + public void flush() throws IOException { + RandomAccessCharacterFile.this.flush(); + } + + @Override + public void write(char[] cb, int off, int len) throws IOException { + RandomAccessCharacterFile.this.write(cb, off, len); + } } @@ -271,214 +269,215 @@ public RandomAccessCharacterFile(RandomAccessFile raf, String encoding) throws IOException { - fcn = raf.getChannel(); - fcnpos = fcn.position(); - fcnsize = fcn.size(); - - cset = (encoding == null) ? Charset.defaultCharset() : Charset.forName(encoding); - cdec = cset.newDecoder(); - cdec.onMalformedInput(CodingErrorAction.REPLACE); - cdec.onUnmappableCharacter(CodingErrorAction.REPLACE); - cenc = cset.newEncoder(); - - bbuf = ByteBuffer.allocate(BUFSIZ); - - // there is no readable data available in the buffers. - bbuf.flip(); - - // there is no write pending data in the buffers. - bbufIsDirty = false; - - bbufpos = fcn.position(); - - reader = new RandomAccessReader(); - writer = new RandomAccessWriter(); - inputStream = new RandomAccessInputStream(); - outputStream = new RandomAccessOutputStream(); + fcn = raf.getChannel(); + fcnpos = fcn.position(); + fcnsize = fcn.size(); + + cset = (encoding == null) ? Charset.defaultCharset() : Charset.forName(encoding); + cdec = cset.newDecoder(); + cdec.onMalformedInput(CodingErrorAction.REPLACE); + cdec.onUnmappableCharacter(CodingErrorAction.REPLACE); + cenc = cset.newEncoder(); + + bbuf = ByteBuffer.allocate(BUFSIZ); + + // there is no readable data available in the buffers. + bbuf.flip(); + + // there is no write pending data in the buffers. + bbufIsDirty = false; + + bbufpos = fcn.position(); + + reader = new RandomAccessReader(); + writer = new RandomAccessWriter(); + inputStream = new RandomAccessInputStream(); + outputStream = new RandomAccessOutputStream(); } public Writer getWriter() { - return writer; + return writer; } public PushbackReader getReader() { - return reader; + return reader; } public PushbackInputStream getInputStream() { - return inputStream; + return inputStream; } public OutputStream getOutputStream() { - return outputStream; + return outputStream; } public void close() throws IOException { - internalFlush(true); - fcn.close(); + internalFlush(true); + fcn.close(); } public void flush() throws IOException { - internalFlush(false); + internalFlush(false); } private int read(char[] cb, int off, int len) throws IOException { - CharBuffer cbuf = CharBuffer.wrap(cb, off, len); - boolean decodeWasUnderflow = false; - boolean atEof = false; - while ((cbuf.remaining() > 0) && dataIsAvailableForRead() - && ! atEof) { - if ((bbuf.remaining() == 0) || decodeWasUnderflow) { - // need to read from the file. - flushBbuf(); // in case bbuf is dirty. - // update bbufpos. - bbufpos += bbuf.position(); - int partialBytes = bbuf.remaining(); // partialBytes > 0 happens when decodeWasUnderflow - // if reads and writes are mixed, we may need to seek first. - if (bbufpos + partialBytes != fcnpos) { - fcn.position(bbufpos + partialBytes); - } - // need to read data from file. - bbuf.compact(); - //###FIXME: we're ignoring end-of-stream here!!! - atEof = (fcn.read(bbuf) == -1); - bbuf.flip(); - fcnpos = bbufpos + bbuf.remaining(); - } - CoderResult r = cdec.decode(bbuf, cbuf, pointingAtEOF() ); - decodeWasUnderflow = (CoderResult.UNDERFLOW == r); - } - if (cbuf.remaining() == len) { - return -1; - } else { - return len - cbuf.remaining(); - } + CharBuffer cbuf = CharBuffer.wrap(cb, off, len); + boolean decodeWasUnderflow = false; + boolean atEof = false; + while ((cbuf.remaining() > 0) && dataIsAvailableForRead() + && ! atEof) { + if ((bbuf.remaining() == 0) || decodeWasUnderflow) { + // need to read from the file. + flushBbuf(); // in case bbuf is dirty. + // update bbufpos. + bbufpos += bbuf.position(); + int partialBytes = bbuf.remaining(); // partialBytes > 0 happens when decodeWasUnderflow + // if reads and writes are mixed, we may need to seek first. + if (bbufpos + partialBytes != fcnpos) { + fcn.position(bbufpos + partialBytes); + } + // need to read data from file. + bbuf.compact(); + //###FIXME: we're ignoring end-of-stream here!!! + atEof = (fcn.read(bbuf) == -1); + bbuf.flip(); + fcnpos = bbufpos + bbuf.remaining(); + } + CoderResult r = cdec.decode(bbuf, cbuf, pointingAtEOF() ); + decodeWasUnderflow = (CoderResult.UNDERFLOW == r); + } + if (cbuf.remaining() == len) { + return -1; + } else { + return len - cbuf.remaining(); + } } private boolean dataIsAvailableForRead() throws IOException { - return ((bbuf.remaining() > 0) || (fcn.position() < fcn.size())); + return ((bbuf.remaining() > 0) || (fcn.position() < fcn.size())); } private boolean pointingAtEOF() { - return (bbuf.remaining() == 0) && (fcnpos == fcnsize); + return (bbuf.remaining() == 0) && (fcnpos == fcnsize); } private void write(char[] cb, int off, int len) throws IOException { - CharBuffer cbuf = CharBuffer.wrap(cb, off, len); - encodeAndWrite(cbuf, false, false); + CharBuffer cbuf = CharBuffer.wrap(cb, off, len); + encodeAndWrite(cbuf, false, false); } private void internalFlush(boolean endOfFile) throws IOException { - if (endOfFile) { - CharBuffer cbuf = CharBuffer.allocate(0); - encodeAndWrite(cbuf, true, endOfFile); - } else { - flushBbuf(); - } + if (endOfFile) { + CharBuffer cbuf = CharBuffer.allocate(0); + encodeAndWrite(cbuf, true, endOfFile); + } else { + flushBbuf(); + } } private void encodeAndWrite(CharBuffer cbuf, boolean flush, boolean endOfFile) throws IOException { - if (bbufpos == fcnsize) { - bbuf.clear(); - } - while (cbuf.remaining() > 0) { - CoderResult r = cenc.encode(cbuf, bbuf, endOfFile); - bbufIsDirty = true; - long curpos = bbufpos + bbuf.position(); - if (curpos > fcnsize) { - // the file is extended. - fcnsize = curpos; - } - if (CoderResult.OVERFLOW == r || bbuf.remaining() == 0) { - flushBbuf(); - bbufpos += bbuf.limit(); - bbuf.clear(); - if (fcnpos < fcnsize) { - fcn.read(bbuf); - bbuf.flip(); - fcnpos += bbuf.remaining(); - } - // if we are at the end of file, bbuf is simply cleared. - // in that case, bbufpos + bbuf.position points to the EOF, not fcnpos. - } - } - if (bbuf.position() > 0 && bbufIsDirty && flush) { - flushBbuf(); - } + if (bbufpos == fcnsize) { + bbuf.clear(); + } + while (cbuf.remaining() > 0) { + CoderResult r = cenc.encode(cbuf, bbuf, endOfFile); + bbufIsDirty = true; + long curpos = bbufpos + bbuf.position(); + if (curpos > fcnsize) { + // the file is extended. + fcnsize = curpos; + } + if (CoderResult.OVERFLOW == r || bbuf.remaining() == 0) { + flushBbuf(); + bbufpos += bbuf.limit(); + bbuf.clear(); + if (fcnpos < fcnsize) { + fcn.read(bbuf); + bbuf.flip(); + fcnpos += bbuf.remaining(); + } + // if we are at the end of file, bbuf is simply cleared. + // in that case, bbufpos + bbuf.position points to the EOF, not fcnpos. + } + } + if (bbuf.position() > 0 && bbufIsDirty && flush) { + flushBbuf(); + } } public void position(long newPosition) throws IOException { - flushBbuf(); - long bbufend = bbufpos + bbuf.limit(); - if (newPosition >= bbufpos && newPosition < bbufend) { - // near seek. within existing data of bbuf. - bbuf.position((int)(newPosition - bbufpos)); - } else { - // far seek. discard the buffer. - flushBbuf(); - fcn.position(newPosition); - fcnpos = newPosition; - bbuf.clear(); - bbuf.flip(); // "there is no useful data on this buffer yet." - bbufpos = fcnpos; - } + flushBbuf(); + long bbufend = bbufpos + bbuf.limit(); + if (newPosition >= bbufpos && newPosition < bbufend) { + // near seek. within existing data of bbuf. + bbuf.position((int)(newPosition - bbufpos)); + } else { + // far seek. discard the buffer. + flushBbuf(); + fcn.position(newPosition); + fcnpos = newPosition; + bbuf.clear(); + bbuf.flip(); // "there is no useful data on this buffer yet." + bbufpos = fcnpos; + } } public long position() throws IOException { - flushBbuf(); - return bbufpos + bbuf.position(); // the logical position within the file. + flushBbuf(); + return bbufpos + bbuf.position(); // the logical position within the file. } public long length() throws IOException { - flushBbuf(); - return fcn.size(); + flushBbuf(); + return fcn.size(); } - + private void flushBbuf() throws IOException { - if (bbufIsDirty) { - if (fcnpos != bbufpos) { - fcn.position(bbufpos); - } - bbuf.position(0); - if (bbufpos + bbuf.limit() > fcnsize) { - // the buffer is at the end of the file. - // area beyond fcnsize does not have data. - bbuf.limit((int)(fcnsize - bbufpos)); - } - fcn.write(bbuf); - fcnpos = bbufpos + bbuf.limit(); - bbufIsDirty = false; - } + if (! bbufIsDirty) + return; + + if (fcnpos != bbufpos) + fcn.position(bbufpos); + + bbuf.position(0); + if (bbufpos + bbuf.limit() > fcnsize) { + // the buffer is at the end of the file. + // area beyond fcnsize does not have data. + bbuf.limit((int)(fcnsize - bbufpos)); + } + fcn.write(bbuf); + fcnpos = bbufpos + bbuf.limit(); + bbufIsDirty = false; } public int read(byte[] b, int off, int len) throws IOException { - int pos = off; - boolean atEof = false; - while (pos - off < len && dataIsAvailableForRead() - && ! atEof) { - if (bbuf.remaining() == 0) { - // need to read from the file. - flushBbuf(); // in case bbuf is dirty. - // update bbufpos. - bbufpos += bbuf.limit(); - // if reads and writes are mixed, we may need to seek first. - if (bbufpos != fcnpos) { - fcn.position(bbufpos); - } - // need to read data from file. - bbuf.clear(); - atEof = (fcn.read(bbuf) == -1); - bbuf.flip(); - fcnpos = bbufpos + bbuf.remaining(); - } - int want = len - pos; - if (want > bbuf.remaining()) { - want = bbuf.remaining(); - } - bbuf.get(b, pos, want); - pos += want; - } - return pos - off; + int pos = off; + boolean atEof = false; + while (pos - off < len && dataIsAvailableForRead() + && ! atEof) { + if (bbuf.remaining() == 0) { + // need to read from the file. + flushBbuf(); // in case bbuf is dirty. + // update bbufpos. + bbufpos += bbuf.limit(); + // if reads and writes are mixed, we may need to seek first. + if (bbufpos != fcnpos) { + fcn.position(bbufpos); + } + // need to read data from file. + bbuf.clear(); + atEof = (fcn.read(bbuf) == -1); + bbuf.flip(); + fcnpos = bbufpos + bbuf.remaining(); + } + int want = len - pos; + if (want > bbuf.remaining()) { + want = bbuf.remaining(); + } + bbuf.get(b, pos, want); + pos += want; + } + return pos - off; } // a method corresponding to the good ol' ungetc in C. @@ -490,65 +489,73 @@ private CharBuffer singleCharBuf; private ByteBuffer shortByteBuf; public void unreadChar(char c) throws IOException { - // algorithm : - // 1. encode c into bytes, to find out how many bytes it corresponds to - // 2. move the position backwards that many bytes. - // ** we stop here. Don't bother to write the bytes to the buffer, - // assuming that it is the same as the original data. - // If we allow to write back different characters, the buffer must get 'dirty' - // but that would require read/write permissions on files you use unreadChar, - // even if you are just reading for some tokenizer. - // - // So we don't do the following. - // 3. write the bytes. - // 4. move the position back again. - if (singleCharBuf == null) { - singleCharBuf = CharBuffer.allocate(1); - shortByteBuf = ByteBuffer.allocate((int)cenc.maxBytesPerChar()); - } - singleCharBuf.clear(); - singleCharBuf.append(c); - singleCharBuf.flip(); - shortByteBuf.clear(); - cenc.encode(singleCharBuf, shortByteBuf, false); - int n = shortByteBuf.position(); - long pos = position() - n; - position(pos); + // algorithm : + // 1. encode c into bytes, to find out how many bytes it corresponds to + // 2. move the position backwards that many bytes. + // ** we stop here. Don't bother to write the bytes to the buffer, + // assuming that it is the same as the original data. + // If we allow to write back different characters, the buffer must get 'dirty' + // but that would require read/write permissions on files you use unreadChar, + // even if you are just reading for some tokenizer. + // + // So we don't do the following. + // 3. write the bytes. + // 4. move the position back again. + if (singleCharBuf == null) { + singleCharBuf = CharBuffer.allocate(1); + shortByteBuf = ByteBuffer.allocate((int)cenc.maxBytesPerChar()); + } + singleCharBuf.clear(); + singleCharBuf.append(c); + singleCharBuf.flip(); + shortByteBuf.clear(); + cenc.encode(singleCharBuf, shortByteBuf, false); + int n = shortByteBuf.position(); + long pos = position() - n; + position(pos); } public void unreadByte(byte b) throws IOException { - long pos = position() - 1; - position(pos); + long pos = position() - 1; + position(pos); } private void write(byte[] b, int off, int len) throws IOException { - int pos = off; - while (pos < off + len) { - int want = len; - if (want > bbuf.remaining()) { - want = bbuf.remaining(); - } - bbuf.put(b, pos, want); - pos += want; - bbufIsDirty = true; - long curpos = bbufpos + bbuf.position(); - if (curpos > fcn.size()) { - // the file is extended. - fcnsize = curpos; - } - if (bbuf.remaining() == 0) { - flushBbuf(); - bbufpos += bbuf.limit(); - bbuf.clear(); - if (fcn.position() < fcn.size()) { - bbufpos = fcn.position(); - fcn.read(bbuf); - bbuf.flip(); - fcnpos += bbuf.remaining(); - } - // if we are at the end of file, bbuf is simply cleared. - // in that case, bbufpos + bbuf.position points to the EOF, not fcnpos. - } - } + int pos = off; + if (len > bbuf.limit()) { + if (bbufIsDirty) + flushBbuf(); + fcn.write(ByteBuffer.wrap(b, off, len)); + fcnpos = fcn.position(); + if (fcnpos > fcnsize) + fcnsize = fcnpos; + } + while (pos < off + len) { + int want = len; + if (want > bbuf.remaining()) { + want = bbuf.remaining(); + } + bbuf.put(b, pos, want); + pos += want; + bbufIsDirty = true; + long curpos = bbufpos + bbuf.position(); + if (curpos > fcnsize) { + // the file is extended. + fcnsize = curpos; + } + if (bbuf.remaining() == 0) { + flushBbuf(); + bbufpos += bbuf.limit(); + bbuf.clear(); + if (fcn.position() < fcnsize) { + bbufpos = fcn.position(); + fcn.read(bbuf); + bbuf.flip(); + fcnpos += bbuf.remaining(); + } + // if we are at the end of file, bbuf is simply cleared. + // in that case, bbufpos + bbuf.position points to the EOF, not fcnpos. + } + } } } From ehuelsmann at common-lisp.net Sun May 31 19:46:32 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 31 May 2009 15:46:32 -0400 Subject: [armedbear-cvs] r11971 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Sun May 31 15:46:23 2009 New Revision: 11971 Log: Disentangle flushBbuf() and read(char[]) in RandomAccessCharacterFile; a step toward simplification. Note: It looks like calling fcn.size() is a performance killer on Windows. Working toward removal. Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Sun May 31 15:46:23 2009 @@ -324,24 +324,26 @@ CharBuffer cbuf = CharBuffer.wrap(cb, off, len); boolean decodeWasUnderflow = false; boolean atEof = false; - while ((cbuf.remaining() > 0) && dataIsAvailableForRead() - && ! atEof) { + while ((cbuf.remaining() > 0) && dataIsAvailableForRead() && ! atEof) { if ((bbuf.remaining() == 0) || decodeWasUnderflow) { - // need to read from the file. - flushBbuf(); // in case bbuf is dirty. - // update bbufpos. - bbufpos += bbuf.position(); - int partialBytes = bbuf.remaining(); // partialBytes > 0 happens when decodeWasUnderflow - // if reads and writes are mixed, we may need to seek first. - if (bbufpos + partialBytes != fcnpos) { - fcn.position(bbufpos + partialBytes); - } - // need to read data from file. - bbuf.compact(); - //###FIXME: we're ignoring end-of-stream here!!! - atEof = (fcn.read(bbuf) == -1); - bbuf.flip(); - fcnpos = bbufpos + bbuf.remaining(); + // need to read from the file. + + if (bbufIsDirty) { + bbuf.flip(); + fcn.position(bbufpos); + fcn.write(bbuf); + bbufpos = bbufpos+bbuf.position(); + bbuf.clear(); + } else { + fcn.position(bbufpos + bbuf.limit()); + bbufpos += bbuf.position(); + bbuf.compact(); + } + + atEof = (fcn.read(bbuf) == -1); + fcnpos = fcn.position(); + // update bbufpos. + bbuf.flip(); } CoderResult r = cdec.decode(bbuf, cbuf, pointingAtEOF() ); decodeWasUnderflow = (CoderResult.UNDERFLOW == r); From ehuelsmann at common-lisp.net Sun May 31 22:12:33 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 31 May 2009 18:12:33 -0400 Subject: [armedbear-cvs] r11972 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Sun May 31 18:12:22 2009 New Revision: 11972 Log: Factor out bbuf-updating from read(byte[]) and read(char[]) into ensureReadBbuf(). Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Sun May 31 18:12:22 2009 @@ -320,31 +320,40 @@ internalFlush(false); } + private final boolean ensureReadBbuf(boolean force) throws IOException { + boolean bufReady = true; + + if ((bbuf.remaining() == 0) || force) { + // need to read from the file. + + if (bbufIsDirty) { + bbuf.flip(); + fcn.position(bbufpos); + fcn.write(bbuf); + bbufpos = bbufpos+bbuf.position(); + bbuf.clear(); + } else { + fcn.position(bbufpos + bbuf.limit()); + bbufpos += bbuf.position(); + bbuf.compact(); + } + + bufReady = (fcn.read(bbuf) != -1); + fcnpos = fcn.position(); + // update bbufpos. + bbuf.flip(); + } + + return bufReady; + } + private int read(char[] cb, int off, int len) throws IOException { CharBuffer cbuf = CharBuffer.wrap(cb, off, len); boolean decodeWasUnderflow = false; boolean atEof = false; while ((cbuf.remaining() > 0) && dataIsAvailableForRead() && ! atEof) { - if ((bbuf.remaining() == 0) || decodeWasUnderflow) { - // need to read from the file. - if (bbufIsDirty) { - bbuf.flip(); - fcn.position(bbufpos); - fcn.write(bbuf); - bbufpos = bbufpos+bbuf.position(); - bbuf.clear(); - } else { - fcn.position(bbufpos + bbuf.limit()); - bbufpos += bbuf.position(); - bbuf.compact(); - } - - atEof = (fcn.read(bbuf) == -1); - fcnpos = fcn.position(); - // update bbufpos. - bbuf.flip(); - } + atEof = ! ensureReadBbuf(decodeWasUnderflow); CoderResult r = cdec.decode(bbuf, cbuf, pointingAtEOF() ); decodeWasUnderflow = (CoderResult.UNDERFLOW == r); } @@ -457,21 +466,8 @@ boolean atEof = false; while (pos - off < len && dataIsAvailableForRead() && ! atEof) { - if (bbuf.remaining() == 0) { - // need to read from the file. - flushBbuf(); // in case bbuf is dirty. - // update bbufpos. - bbufpos += bbuf.limit(); - // if reads and writes are mixed, we may need to seek first. - if (bbufpos != fcnpos) { - fcn.position(bbufpos); - } - // need to read data from file. - bbuf.clear(); - atEof = (fcn.read(bbuf) == -1); - bbuf.flip(); - fcnpos = bbufpos + bbuf.remaining(); - } + + atEof = ! ensureReadBbuf(false); int want = len - pos; if (want > bbuf.remaining()) { want = bbuf.remaining();