From astalla at common-lisp.net Mon Nov 1 22:45:03 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 01 Nov 2010 18:45:03 -0400 Subject: [armedbear-cvs] r12993 - branches/invokedynamic/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Nov 1 18:45:00 2010 New Revision: 12993 Log: [invokedynamic] Stack map table written to class (sample); errors. Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Mon Nov 1 18:45:00 2010 @@ -1017,7 +1017,9 @@ (setf (code-code code) c (code-labels code) labels) (when compute-stack-map-table-p - #+todo (code-add-attribute code stack-map-table)))) + (code-add-attribute + code + (make-stack-map-table-attribute :entries stack-map-table))))) (setf (code-exception-handlers code) (remove-if #'(lambda (h) @@ -1094,7 +1096,6 @@ (defun resolve-code (code-attr code class method compute-stack-map-table-p) "Walks the code, replacing symbolic labels with numeric offsets, and optionally computing the stack map table." - (declare (ignore class)) (let* ((length 0) labels ;; alist stack-map-table @@ -1123,7 +1124,7 @@ (if computing-stack-map-table (progn (when (= opcode 202) ;;label: simulate a jump - (record-jump-to-label (car (instruction-args instruction)))) + (record-jump-to-label (first (instruction-args instruction)))) (simulate-instruction-effect instruction) ;;Simulation must be stopped if we encounter a goto, it will be ;;resumed by the next label that is the target of a jump @@ -1139,7 +1140,36 @@ (setf labels (acons label length labels))) (incf length (opcode-size opcode))))) - ;; Pass 2: replace labels with calculated offsets. + ;;Pass 2 (optional): compute the stack map table + (when compute-stack-map-table-p + (let ((last-frame-offset 0) + (must-emit-frame nil)) + (dotimes (i (length code)) + (let ((instruction (aref code i)) + (make-variable-info (lambda (type) + (smf-type->variable-info type class)))) + (cond + ((= (instruction-opcode instruction) 202) ; LABEL + (let* ((label (car (instruction-args instruction))) + (offset (symbol-value label)) + (*print-circle* t)) + (if (get label 'jump-target-p) + (let ((frame + (make-stack-map-full-frame + :offset-delta (- offset last-frame-offset) + :locals + (mapcar make-variable-info + (instruction-input-locals instruction)) + :stack-items + (mapcar make-variable-info + (instruction-input-stack instruction))))) + (push frame stack-map-table) + (sys::%format t "emit frame ~S @ ~A (~A)~%" + frame offset (- offset last-frame-offset)) + (setf last-frame-offset offset)) + (sys::%format t "error - label not target of a jump: ~S~%" label)) + ))))))) + ;;Pass 3: replace labels with calculated offsets. (let ((index 0)) (declare (type (unsigned-byte 16) index)) (dotimes (i (length code)) @@ -1150,12 +1180,11 @@ (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index))) - (unless (get label 'jump-target-p) - (sys::%format "error - label not target of a jump ~S~%" label)) (setf (instruction-args instruction) (s2 offset)))) (unless (= (instruction-opcode instruction) 202) ; LABEL (incf index (opcode-size (instruction-opcode instruction))))))) - ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. + ;;Pass 4: expand instructions into bytes, + ;;skipping LABEL pseudo-instructions. (let ((bytes (make-array length)) (index 0)) (declare (type (unsigned-byte 16) index)) @@ -1169,7 +1198,6 @@ (if (constant-p arg) (let ((idx (constant-index arg)) (opcode (instruction-opcode instruction))) - ;;(sys::%format t "constant ~A ~A index-size ~A index ~A~%" (type-of arg) idx (constant-index-size arg) index) (if (or (<= 178 opcode 187) (= opcode 189) (= opcode 192) @@ -1184,8 +1212,7 @@ (progn (setf (svref bytes index) arg) (incf index))))))) - (sys::%format t "~%~%~%BYTES ~S~%~%~%" bytes) - (values bytes labels stack-map-table)))) + (values bytes labels (nreverse stack-map-table))))) (defun unconditional-jump-p (opcode) (= opcode 167)) @@ -1401,10 +1428,6 @@ "The attribute containing the stack map table, a map from bytecode offsets to frames containing information about the types of locals and values on the operand stack at that offset. This is an attribute of a method." entries) -(defun add-stack-map-frame (stack-map-table instruction-offset locals - stack-items) - (error "TODO!")) - (defun finalize-stack-map-table-attribute (table parent class) "Prepares the `stack-map-table' attribute for serialization, within method `parent': replaces all virtual types in the stack map frames with variable-info objects." (declare (ignore parent class)) ;;TODO @@ -1413,7 +1436,7 @@ (defun write-stack-map-table-attribute (table stream) (write-u2 (length (stack-map-table-entries table)) stream) (dolist (frame (stack-map-table-entries table)) - (funcall (frame-writer frame) stream))) + (funcall (frame-writer frame) frame stream))) (defstruct (stack-map-frame (:conc-name frame-)) offset-delta @@ -1429,6 +1452,9 @@ (defun write-stack-map-full-frame (frame stream) (write-u1 255 stream) (write-u2 (frame-offset-delta frame) stream) +;; (write-u2 0 stream) +;; (write-u2 0 stream) +;; (return-from write-stack-map-full-frame) (write-u2 (length (full-frame-locals frame)) stream) (dolist (local (full-frame-locals frame)) (funcall (verification-type-info-writer local) local stream)) @@ -1456,10 +1482,10 @@ (defun write-simple-verification-type-info (vti stream) (write-u1 (verification-type-info-tag vti) stream)) -(defun write-object-variable-type-info (vti stream) +(defun write-object-variable-info (vti stream) (write-u1 (verification-type-info-tag vti) stream) (write-u2 (object-variable-info-constant-pool-index vti) stream)) -(defun write-uninitialized-verification-type-info (vti stream) +(defun write-uninitialized-variable-info (vti stream) (write-u1 (verification-type-info-tag vti) stream) (write-u2 (uninitialized-variable-info-offset vti) stream)) @@ -1475,8 +1501,18 @@ (push x locals)) (nreverse locals))) -(defun smf-type->variable-info (type) - :todo) +(defun smf-type->variable-info (type class) + (cond + ((eq type :this) + (make-object-variable-info :constant-pool-index (class-file-class class))) + ((eq type :int) (make-integer-variable-info)) + ((typep type 'constant-class) + (make-object-variable-info :constant-pool-index (constant-index type))) + ((typep type 'class-name) + (make-object-variable-info + :constant-pool-index + (constant-index (pool-add-class (class-file-constants class) type)))) + (t (sys::%format t "Don't know how to translate type ~S~%" type) type))) #| From astalla at common-lisp.net Tue Nov 2 23:48:39 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 02 Nov 2010 19:48:39 -0400 Subject: [armedbear-cvs] r12994 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Nov 2 19:48:36 2010 New Revision: 12994 Log: New high-level Java interop macros: 'chain' for chained method invocations ? la Clojure's '..' operator, and 'jmethod-let'. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/java.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 Tue Nov 2 19:48:36 2010 @@ -282,6 +282,10 @@ (autoload 'jruntime-class-exists-p "runtime-class") (export 'ensure-java-class "JAVA") (autoload 'ensure-java-class "java") +(export 'chain "JAVA") +(autoload-macro 'chain "java") +(export 'jmethod-let "JAVA") +(autoload-macro 'jmethod-let "java") ;; Profiler. (in-package "PROFILER") 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 Tue Nov 2 19:48:36 2010 @@ -337,6 +337,45 @@ (defun (setf jproperty-value) (value obj prop) (%jset-property-value obj prop value)) +;;; higher-level operators + +(defmacro chain (target op &rest ops) + "Performs chained method invocations. `target' is the receiver object (when the first call is a virtual method call) or a list in the form (:static ) when the first method call is a static method call. `op' and each of the `ops' are either method designators or lists in the form ( &rest args), where a method designator is either a string naming a method, or a jmethod object. `chain' will perform the method call specified by `op' on `target'; then, for each of the `ops', `chain' will perform the specified method call using the object returned by the previous method call as the receiver, and will ultimately return the result of the last method call. + For example, the form: + + (chain (:static \"java.lang.Runtime\") \"getRuntime\" (\"exec\" \"ls\")) + + is equivalent to the following Java code: + + java.lang.Runtime.getRuntime().exec(\"ls\");" + (labels ((canonicalize-op (op) (if (listp op) op (list op))) + (compose-arglist (target op) `(,(car op) ,target ,@(cdr op))) + (make-binding-for (form) `(,(gensym) ,form)) + (make-binding (bindings next-op &aux (target (caar bindings))) + (cons (make-binding-for + `(jcall ,@(compose-arglist target + (canonicalize-op next-op)))) + bindings))) + (let* ((first (if (and (consp target) (eq (first target) :static)) + `(jstatic ,@(compose-arglist (cadr target) (canonicalize-op op))) + `(jcall ,@(compose-arglist target (canonicalize-op op))))) + (bindings (nreverse + (reduce #'make-binding ops + :initial-value (list (make-binding-for first)))))) + `(let* ,bindings + (declare (ignore ,@(mapcar #'car bindings))))))) + +(defmacro jmethod-let (bindings &body body) + (let ((args (gensym))) + `(let ,(mapcar (lambda (binding) + `(,(car binding) (jmethod ,@(cdr binding)))) + bindings) + (macrolet ,(mapcar (lambda (binding) + `(,(car binding) (&rest ,args) + `(jcall ,,(car binding) ,@,args))) + bindings) + , at body)))) + ;;; print-object (defmethod print-object ((obj java:java-object) stream) From ehuelsmann at common-lisp.net Thu Nov 4 10:09:18 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 06:09:18 -0400 Subject: [armedbear-cvs] r12995 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 4 06:09:16 2010 New Revision: 12995 Log: Fix JRockit crashing on our byte code. Found by: Joel Borggr?n-Franck joel (dot) borggren (dot) franck gmail.com Patch by: me 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 Nov 4 06:09:16 2010 @@ -3601,6 +3601,10 @@ (emit-push-variable (block-id-variable block)) ;; If it's not the block we're looking for... (emit 'if_acmpeq THIS-BLOCK) ; Stack depth is 1. + ;; Not the tag we're looking for. + (emit 'aconst_null) ;; load null value + (emit-move-to-variable (block-id-variable block)) + (emit 'athrow) (label EXTENT-EXIT-HANDLER) ;; Not the tag we're looking for. (emit 'aconst_null) ;; load null value From ehuelsmann at common-lisp.net Thu Nov 4 13:41:41 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 09:41:41 -0400 Subject: [armedbear-cvs] r12996 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 4 09:41:38 2010 New Revision: 12996 Log: Fix JRockit crashing on our byte code - second occurrance. Found by: Joel Borggr?n-Franck joel (dot) borggren (dot) franck gmail.com Patch by: me 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 Nov 4 09:41:38 2010 @@ -6447,6 +6447,7 @@ (BEGIN-PROTECTED-RANGE (gensym)) (END-PROTECTED-RANGE (gensym)) (THROW-HANDLER (gensym)) + (RETHROW (gensym)) (DEFAULT-HANDLER (gensym)) (EXIT (gensym))) (compile-form (second form) tag-register nil) ; Tag. @@ -6473,6 +6474,11 @@ (list +lisp-thread+) +lisp-object+) (emit-move-from-stack target) ; Stack depth is 0. (emit 'goto EXIT) + (label RETHROW) ; Start of handler for all other Throwables. + ;; A Throwable object is on the runtime stack here. Stack depth is 1. + (emit-push-current-thread) + (emit-invokevirtual +lisp-thread+ "popCatchTag" nil nil) + (emit 'athrow) ; Re-throw. (label DEFAULT-HANDLER) ; Start of handler for all other Throwables. ;; A Throwable object is on the runtime stack here. Stack depth is 1. (emit-push-current-thread) From ehuelsmann at common-lisp.net Thu Nov 4 15:52:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 11:52:35 -0400 Subject: [armedbear-cvs] r12997 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 4 11:52:33 2010 New Revision: 12997 Log: Truely fix JRockit: actually use the new label to jump to. 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 Nov 4 11:52:33 2010 @@ -6468,7 +6468,7 @@ (aload tag-register) ; Stack depth is 3. ;; 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. + (emit 'if_acmpne RETHROW) ; Stack depth is 1. (emit-push-current-thread) (emit-invokevirtual +lisp-throw+ "getResult" (list +lisp-thread+) +lisp-object+) From ehuelsmann at common-lisp.net Thu Nov 4 19:35:16 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 15:35:16 -0400 Subject: [armedbear-cvs] r12998 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Nov 4 15:35:13 2010 New Revision: 12998 Log: Update CHANGES. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Thu Nov 4 15:35:13 2010 @@ -8,9 +8,15 @@ * [svn r12986] Update to ASDF 2.010.1 +* [svn r12982] Basic support for the long form of DEFINE-METHOD-COMBINATION + +* [svn r12994] New java-interop macros: CHAIN and JMETHOD-LET + Fixes ----- +* [ticket #98] THREAD type specifier not exported from the THREADS package + * [svn r12946] Fix CLOS thread-safety * [svn r12930] Fix non-constantness of constant symbols when using SET @@ -44,6 +50,11 @@ of generic class file writer, elimination of special purpose code in the compiler. +* Number of hashtable implementations reduced to 1 (from 5) + +* Reduced use of 'synchronized' global hash table access by using + the java.util.concurrent package + Version 0.22 ============ svn://common-lisp.net/project/armedbear/svn/tags/0.22.0/abcl From ehuelsmann at common-lisp.net Thu Nov 4 19:42:08 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 15:42:08 -0400 Subject: [armedbear-cvs] r12999 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Nov 4 15:42:08 2010 New Revision: 12999 Log: Forgot the most important update of all. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Thu Nov 4 15:42:08 2010 @@ -15,6 +15,8 @@ Fixes ----- +* Various fixes in order to complete the Maxima test suite without failures + * [ticket #98] THREAD type specifier not exported from the THREADS package * [svn r12946] Fix CLOS thread-safety From ehuelsmann at common-lisp.net Thu Nov 4 19:53:00 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 15:53:00 -0400 Subject: [armedbear-cvs] r13000 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Nov 4 15:53:00 2010 New Revision: 13000 Log: Update CHANGES. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Thu Nov 4 15:53:00 2010 @@ -15,6 +15,9 @@ Fixes ----- +* [svn r12995-12997] Changes to generated byte code to prevent JRocket JVM + from crashing when optimizing it + * Various fixes in order to complete the Maxima test suite without failures * [ticket #98] THREAD type specifier not exported from the THREADS package From ehuelsmann at common-lisp.net Thu Nov 4 20:14:13 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 16:14:13 -0400 Subject: [armedbear-cvs] r13001 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Nov 4 16:14:12 2010 New Revision: 13001 Log: s/JRocket/JRockit/. Found by: Ville Voutilainen. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Thu Nov 4 16:14:12 2010 @@ -15,7 +15,7 @@ Fixes ----- -* [svn r12995-12997] Changes to generated byte code to prevent JRocket JVM +* [svn r12995-12997] Changes to generated byte code to prevent JRockit JVM from crashing when optimizing it * Various fixes in order to complete the Maxima test suite without failures From ehuelsmann at common-lisp.net Thu Nov 4 22:42:29 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 18:42:29 -0400 Subject: [armedbear-cvs] r13002 - public_html Message-ID: Author: ehuelsmann Date: Thu Nov 4 18:42:25 2010 New Revision: 13002 Log: Add FAQ items and re-index. Fix small errors in 0.22 release notes page. Modified: public_html/faq.shtml public_html/release-notes-0.22.shtml Modified: public_html/faq.shtml ============================================================================== --- public_html/faq.shtml (original) +++ public_html/faq.shtml Thu Nov 4 18:42:25 2010 @@ -25,6 +25,8 @@
  • How/Where should I report bugs?
  • Is ABCL faster or slower than implementation XYZ?
  • What is the quality of the implementation? How can you tell?
    • +
  • Where is ABCL's source code repository?
    • +
  • Where is ABCL's documentation?
    • @@ -140,13 +142,14 @@ 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 +

    ABCL 0.23.0 fails 31 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 0.23.0 is able to run the test suite without failures, coming from + 'only' ca 75 failing tests at the time of 0.15.0, and even 1400 failures + around October 2008.

    @@ -159,6 +162,21 @@ +
    +

    Where is ABCL's documentation?

    + +

    Documentation on ABCL can be found in several places, depending on the + kind of documentation you're looking for.

    + +
      +
    1. Our wiki
      2. +
    2. The source + code (JavaDoc and general comments)
      3. +
    3. Specific examples
      4. +
    + +
    Modified: public_html/release-notes-0.22.shtml ============================================================================== --- public_html/release-notes-0.22.shtml (original) +++ public_html/release-notes-0.22.shtml Thu Nov 4 18:42:25 2010 @@ -3,7 +3,7 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> - ABCL - Release notes v0.21 + ABCL - Release notes v0.22 @@ -20,7 +20,7 @@

    Most notable changes in ABCL 0.22

    -

    Release notes for older releases.

    +

    Release notes for older releases.

    Fix reading non-UTF8 characters on UTF-8 input streams.
    From ehuelsmann at common-lisp.net Thu Nov 4 23:07:23 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 19:07:23 -0400 Subject: [armedbear-cvs] r13003 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Nov 4 19:07:22 2010 New Revision: 13003 Log: Rephrase a little bit. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Thu Nov 4 19:07:22 2010 @@ -8,7 +8,8 @@ * [svn r12986] Update to ASDF 2.010.1 -* [svn r12982] Basic support for the long form of DEFINE-METHOD-COMBINATION +* [svn r12982] Experimental support for the long form + of DEFINE-METHOD-COMBINATION * [svn r12994] New java-interop macros: CHAIN and JMETHOD-LET From ehuelsmann at common-lisp.net Thu Nov 4 23:08:37 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 19:08:37 -0400 Subject: [armedbear-cvs] r13004 - public_html Message-ID: Author: ehuelsmann Date: Thu Nov 4 19:08:35 2010 New Revision: 13004 Log: Don't claim we improved the number of failing tests when we really didn't for a number of releases. Modified: public_html/faq.shtml Modified: public_html/faq.shtml ============================================================================== --- public_html/faq.shtml (original) +++ public_html/faq.shtml Thu Nov 4 19:08:35 2010 @@ -143,8 +143,8 @@ improve this measure too.

    ABCL 0.23.0 fails 31 out of 21702 tests in the ANSI test suite - in interpreted and compiled modes, coming from ca 44 in the last - release.

    + in interpreted and compiled modes, a constant number over the past + releases. Most failures relate to pretty printing.

    As a measure of 'improvement achieved', the development team refers to the number of failing tests in the Maxima test suite too. ABCL 0.23.0 is able to run the test suite without failures, coming from From ehuelsmann at common-lisp.net Thu Nov 4 23:10:19 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Nov 2010 19:10:19 -0400 Subject: [armedbear-cvs] r13005 - public_html Message-ID: Author: ehuelsmann Date: Thu Nov 4 19:10:17 2010 New Revision: 13005 Log: Prepare 0.23 release; commit release notes, but don't link to them yet. Added: public_html/release-notes-0.23.shtml Added: public_html/release-notes-0.23.shtml ============================================================================== --- (empty file) +++ public_html/release-notes-0.23.shtml Thu Nov 4 19:10:17 2010 @@ -0,0 +1,71 @@ + + + + + ABCL - Release notes v0.23 + + + + + +

    +

    ABCL - Release notes for version 0.23

    +
    + + + +
    + +

    Most notable changes in ABCL 0.23

    + + +

    Release notes for older releases.

    + +
    +
    No more failures in Maxima's test suite
    +
    Working together with the developers from the Maxima program, we've been + able to identify the causes for the last few remaining failures and + apply fixes - mostly to ABCL, but some in Maxima too. Thanks guys!
    +
    Fixes to stop JRockit JVM's optimizer from crashing
    +
    Some specific aspects of the byte code we generated was a problem + for the optimizer in JRockit JVM. JRockit has been fixed, but the release + won't be out for some time. Since we identified the offending code, we + decided to change our byte code as well.
    +
    Fixes to CLOS thread safety.
    +
    Taking advantage of the java.util.concurrent package, we have both been + able to eliminate many synchronized blocks, reducing chances for + contention as well as increasing protection by using types with built-in + protection. +
    +
    Updated ASDF2
    +
    ASDF2 has been updated to its latest version 2.010.1
    +
    Experimental support for the long form of DEFINE-METHOD-COMBINATION
    +
    Support for the long form of DEFINE-METHOD-COMBINATION has been added, + however, this support is derived from Sacla and XCL, which probably means + that the code hasn't been excercised all that much and does contain + bugs. You're strongly urged to help debug and define test-cases in order + to fix any issues in the code.
    +
    A new (generic) class writer
    +
    Our compiler used to contain code to generate class files which exactly + match ABCL's usage patterns. However, in order to expand ABCL's compiler + possibilities - as well as providing support for extension of Java classes + at runtime - a more generic class file generator is required. We have one + now!
    + +
    + + + + +
    +
    +

    Back to Common-lisp.net.

    + +
    + Valid XHTML 1.0 Strict +
    +
    $Id: release-notes-0.22.shtml 12925 2010-09-26 17:39:13Z ehuelsmann $
    +
    + + From ehuelsmann at common-lisp.net Sat Nov 6 08:58:58 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Nov 2010 04:58:58 -0400 Subject: [armedbear-cvs] r13006 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Nov 6 04:58:57 2010 New Revision: 13006 Log: Reduce the number of exceptions generated inside ABCL while compiling Maxima by way over 90% (1.3M+ to 100k-). Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat Nov 6 04:58:57 2010 @@ -936,9 +936,24 @@ } public static boolean isValidURL(String s) { + // On Windows, the scheme "[A-Z]:.*" is ambiguous; reject as urls + // This special case reduced exceptions while compiling Maxima by 90%+ + if (Utilities.isPlatformWindows && s.length() >= 2 && s.charAt(1) == ':') { + char c = s.charAt(0); + if (('A' <= s.charAt(0) && s.charAt(0) <= 'Z') + || ('a' <= s.charAt(0) && s.charAt(0) <= 'z')) + return false; + } + + if (s.indexOf(':') == -1) // no schema separator; can't be valid + return false; + try { URL url = new URL(s); } catch (MalformedURLException e) { + // Generating an exception is a heavy operation, + // we want to try hard not to get into this branch, without + // implementing the URL class ourselves return false; } return true; From ehuelsmann at common-lisp.net Sat Nov 6 12:37:28 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Nov 2010 08:37:28 -0400 Subject: [armedbear-cvs] r13007 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Nov 6 08:37:25 2010 New Revision: 13007 Log: Eliminate ~80k exceptions (ClassNotFoundException) during Maxima compilation by making our FaslClassLoader handle its own classes first. Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Sat Nov 6 08:37:25 2010 @@ -52,11 +52,43 @@ this.loader = (LispObject) loadClass(baseName + "_0").newInstance(); } catch(Exception e) { //e.printStackTrace(); - Debug.trace("useLoaderFunction = true but couldn't fully init FASL loader, will fall back to reflection!"); + Debug.trace("useLoaderFunction = true but couldn't fully init FASL loader ("+baseName+"), will fall back to reflection!"); } } } + @Override + protected Class loadClass(String name, boolean resolve) + throws ClassNotFoundException { + /* First we check if we should load the class ourselves, + * allowing the default handlers to kick in if we don't... + * + * This strategy eliminates ClassNotFound exceptions inside + * the inherited loadClass() eliminated ~80k exceptions during + * Maxima compilation. Generally, creation of an exception object + * is a pretty heavy operation, because it processes the call stack, + * which - in ABCL - is pretty deep, most of the time. + */ + if (name.startsWith(baseName + "_")) { + String internalName = "org/armedbear/lisp/" + name; + Class c = this.findLoadedClass(internalName); + + if (c == null) + c = findClass(name); + + if (c != null) { + if (resolve) + resolveClass(c); + + return c; + } + } + + // Fall through to our super's default handling + return super.loadClass(name, resolve); + } + + @Override protected Class findClass(String name) throws ClassNotFoundException { try { byte[] b = getFunctionClassBytes(name); From mevenson at common-lisp.net Sun Nov 7 12:10:31 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 07 Nov 2010 07:10:31 -0500 Subject: [armedbear-cvs] r13008 - trunk/abcl Message-ID: Author: mevenson Date: Sun Nov 7 07:10:30 2010 New Revision: 13008 Log: Guard implementation specific portions of ABCL test suite. This allows other Lisp implementations to run the ABCL test suite to compare results, which can also be done at a per-test level within the test files themselves if neeed. Modified: trunk/abcl/abcl.asd Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Sun Nov 7 07:10:30 2010 @@ -20,6 +20,10 @@ (operate 'test-op :abcl-tests :force t)) ;;; Test ABCL with the Lisp unit tests collected in "test/lisp/abcl" +;;; +;;; We guard with #+abcl for tests that other Lisps cannot load. This +;;; could be possibly be done at finer granularity in the files +;;; themselves. (defsystem :abcl-test-lisp :version "1.1" :components ((:module abcl-rt :pathname "test/lisp/abcl/" :serial t :components @@ -32,7 +36,9 @@ :pathname "test/lisp/abcl/" :components ((:file "compiler-tests") (:file "condition-tests") + #+abcl (:file "class-file") + #+abcl (:file "metaclass") #+abcl (:file "mop-tests-setup") @@ -47,7 +53,9 @@ (:file "math-tests") (:file "misc-tests") (:file "latin1-tests") + #+abcl (:file "bugs" :depends-on ("file-system-tests")) + #+abcl (:file "pathname-tests"))))) (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp)))) From mevenson at common-lisp.net Sun Nov 7 12:10:38 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 07 Nov 2010 07:10:38 -0500 Subject: [armedbear-cvs] r13009 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Sun Nov 7 07:10:37 2010 New Revision: 13009 Log: Docstring for RUN-MATCHING utility. Modified: trunk/abcl/test/lisp/abcl/package.lisp Modified: trunk/abcl/test/lisp/abcl/package.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/package.lisp (original) +++ trunk/abcl/test/lisp/abcl/package.lisp Sun Nov 7 07:10:37 2010 @@ -22,6 +22,7 @@ ;;; XXX move this into test-utilities.lisp? (defun run-matching (&optional (match *last-run-matching*)) + "Run all tests in suite whose symbol contains MATCH in a case-insensitive manner." (setf *last-run-matching* match) (let* ((matching (string-upcase match)) (tests From mevenson at common-lisp.net Sun Nov 7 12:10:46 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 07 Nov 2010 07:10:46 -0500 Subject: [armedbear-cvs] r13010 - in trunk/abcl: . test/lisp/abcl Message-ID: Author: mevenson Date: Sun Nov 7 07:10:45 2010 New Revision: 13010 Log: Test for working :WILD-INFERIORS. Added tests in 'test/lisp/abcl/wild-inferiors.lisp', for which Ville's implementation passes. Added: trunk/abcl/test/lisp/abcl/wild-pathnames.lisp Modified: trunk/abcl/abcl.asd Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Sun Nov 7 07:10:45 2010 @@ -55,6 +55,7 @@ (:file "latin1-tests") #+abcl (:file "bugs" :depends-on ("file-system-tests")) + (:file "wild-pathnames" :depends-on ("file-system-tests")) #+abcl (:file "pathname-tests"))))) Added: trunk/abcl/test/lisp/abcl/wild-pathnames.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/wild-pathnames.lisp Sun Nov 7 07:10:45 2010 @@ -0,0 +1,56 @@ +(in-package :abcl.test.lisp) + +;;; Various tests for PATHNAMES :WILD and :WILD-INFERIORS + +(defvar *test-files* + '("foo.ext" "a/b/c/foo.ext" "a/d/e/foo.ext" "b/foo.ext" "a/foo.ext")) + +(defvar *temp-directory-root* + (merge-pathnames "tmp/" *this-directory*)) + +(defun create-wild-test-hierarchy () + (dolist (file *test-files*) + (let ((file (merge-pathnames file *temp-directory-root*))) + (ensure-directories-exist (directory-namestring file)) + (touch file)))) + +(defun remove-wild-test-hierarchy () + (delete-directory-and-files *temp-directory-root*)) + +(defmacro with-test-directories (&rest body) + `(prog2 (create-wild-test-hierarchy) + , at body + (remove-wild-test-hierarchy))) + +(defun set-equal (a b) + (and + (= (length a) (length b)) + (subsetp a b :test #'equal) + (subsetp b a :test #'equal))) + +(deftest wild-pathnames.1 + (let ((results + (with-test-directories + (directory (merge-pathnames "**/*.ext" + *temp-directory-root*)))) + (expected + (loop :for file :in *test-files* + :collecting (merge-pathnames file + *temp-directory-root*)))) + (set-equal results expected)) + t) + +;;; XXX try to track this down by going to the git version? +;;; +;;; Passing, but some form of :VERSION :NEWEST was failing for +;;; ASDF-2.116 according to Far? in proviate email of 18.08.2010 +(deftest wild-pathnames.2 + (equal + (first (with-test-directories + (directory (make-pathname :directory (pathname-directory *temp-directory-root*) + :name :wild :type "ext" + :version :newest)))) + (merge-pathnames *temp-directory-root* "foo.ext")) + t) + + From mevenson at common-lisp.net Sun Nov 7 12:10:56 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 07 Nov 2010 07:10:56 -0500 Subject: [armedbear-cvs] r13011 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Sun Nov 7 07:10:55 2010 New Revision: 13011 Log: Test that MAKE-PATHNAME checks its arguments Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/pathname-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/pathname-tests.lisp Sun Nov 7 07:10:55 2010 @@ -1659,3 +1659,10 @@ ;;#+windows "\\foo" ) t) + +(deftest make-pathname.1 + (handler-case + (make-pathname :directory #p"/tmp/") + (type-error () t)) + t) + From astalla at common-lisp.net Sun Nov 7 21:59:48 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 07 Nov 2010 16:59:48 -0500 Subject: [armedbear-cvs] r13012 - public_html Message-ID: Author: astalla Date: Sun Nov 7 16:59:44 2010 New Revision: 13012 Log: Updated my testimonial (Alessio Stalla) Modified: public_html/testimonials.shtml Modified: public_html/testimonials.shtml ============================================================================== --- public_html/testimonials.shtml (original) +++ public_html/testimonials.shtml Sun Nov 7 16:59:44 2010 @@ -75,14 +75,15 @@ the development of this terrific package, a big THANK YOU!!!" -
    Alessio Stalla +
    Alessio Stalla - November, 2010
    -
    I'm currently integrating ABCL in a small, unreleased open source -project. It's a sort of graphical object browser for Java (but its GUI -sucks badly for now...). It can be run locally or as a client-server -application. I'm adding scripting support so you can access some -functionality from Lisp (or in principle any other Java Scripting API -compatible script engine, though I'm focusing on ABCL). +
    With my Java background and my love for Lisp, I've found ABCL to be the ideal choice for my open source projects, in particular: +
      +
    • DynaSpring (http://code.google.com/p/dynaspring/), a Lisp-based DSL for the Spring framework: it replaces the ugly-ugly XML with our beloved parentheses, bringing new features to Spring (conditional evaluation, modularity constructs, etc.) and making it much more user-extensible;
      • +
    • Snow (http://common-lisp.net/project/snow/), a declarative GUI language in the vein of XUL, but obviously Lisp-based, targeting Swing. While still lacking many things, it combines a Lisp DSL with existing Java libraries to concisely describe the structure and layout of the GUI, and to make it easy to connect the UI with the application, thanks to its integration with Cells;
      • +
    • and all the other experimental, unreleased stuff I do as a hobby (mainly related to web development and enterprise application development).
      • +
    +For me ABCL's selling point is of course its interoperability with Java and the consequent access to Java libraries, but I also appreciate its simplicity, portability (even FASLs are cross-platform, thanks to the JVM), and last but not least, the small but vibrant and helpful community.
    Hunter Monroe From ehuelsmann at common-lisp.net Mon Nov 8 22:34:21 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 08 Nov 2010 17:34:21 -0500 Subject: [armedbear-cvs] r13013 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Nov 8 17:34:18 2010 New Revision: 13013 Log: Reduce the impact of the fasl-loader "_0" class's maximum size of 64kB: this change reduces the size of pprint_0.cls from 23001 to 19380 bytes, a saving of 18.64%, which is probably much more when counting the size of the execute() method alone. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Nov 8 17:34:18 2010 @@ -679,7 +679,14 @@ (defun generate-loader-function () (let* ((basename (base-classname)) (expr `(lambda (fasl-loader fn-index) - (identity fasl-loader) ;;to avoid unused arg + (declare (type (integer 0 256000) fn-index)) + (identity fasl-loader) ;;to avoid unused arg + (jvm::with-inline-code () + (jvm::emit 'jvm::aload 1) + (jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance" + nil jvm::+java-object+) + (jvm::emit-checkcast +fasl-classloader+) + (jvm::emit 'jvm::iload 2)) (ncase fn-index 0 ,(1- *class-number*) ,@(loop :for i :from 1 :to *class-number* @@ -687,20 +694,14 @@ (let* ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)) (class-name (jvm::make-class-name class))) - `(,(1- i) - (jvm::with-inline-code () - (jvm::emit 'jvm::aload 1) - (jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance" - nil jvm::+java-object+) - (jvm::emit-checkcast +fasl-classloader+) - (jvm::emit 'jvm::dup) - (jvm::emit-push-constant-int ,(1- i)) - (jvm::emit-new ,class-name) - (jvm::emit 'jvm::dup) - (jvm::emit-invokespecial-init ,class-name '()) - (jvm::emit-invokevirtual +fasl-classloader+ + `(,(1- i) + (jvm::with-inline-code () + (jvm::emit-new ,class-name) + (jvm::emit 'jvm::dup) + (jvm::emit-invokespecial-init ,class-name '()) + (jvm::emit-invokevirtual +fasl-classloader+ "putFunction" - (list :int jvm::+lisp-object+) jvm::+lisp-object+) + (list :int jvm::+lisp-object+) jvm::+lisp-object+) (jvm::emit 'jvm::pop)) t)))))) (classname (fasl-loader-classname)) From ehuelsmann at common-lisp.net Mon Nov 8 22:35:32 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 08 Nov 2010 17:35:32 -0500 Subject: [armedbear-cvs] r13014 - branches/0.23.x Message-ID: Author: ehuelsmann Date: Mon Nov 8 17:35:31 2010 New Revision: 13014 Log: Create 0.23.x release branch. Added: branches/0.23.x/ - copied from r13013, /trunk/ From ehuelsmann at common-lisp.net Tue Nov 9 15:54:27 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 09 Nov 2010 10:54:27 -0500 Subject: [armedbear-cvs] r13015 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Nov 9 10:54:26 2010 New Revision: 13015 Log: Eliminate duplicate lookups in JHandler Patch by: Mario Lang, mlang at delysid dot org Modified: trunk/abcl/src/org/armedbear/lisp/JHandler.java Modified: trunk/abcl/src/org/armedbear/lisp/JHandler.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JHandler.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JHandler.java Tue Nov 9 10:54:26 2010 @@ -66,23 +66,30 @@ public static void callLisp (String s, Object o, String as[], int ai[]) { if (table.containsKey(o)) { - Map entryTable = (Map)table.get(o); + Map entryTable = table.get(o); if (entryTable.containsKey(s)) { - Function f = ((Entry)entryTable.get(s)).getHandler(); - LispObject data = ((Entry)entryTable.get(s)).getData(); - Fixnum count = ((Entry)entryTable.get(s)).getCount(); - Fixnum[] lispAi = new Fixnum[ai.length]; + final Entry entry = entryTable.get(s); + final Function f = entry.getHandler(); + final LispObject data = entry.getData(); + final Fixnum count = entry.getCount(); + final Fixnum[] lispAi = new Fixnum[ai.length]; for (int i = 0; i < ai.length; i++) { lispAi[i] = Fixnum.getInstance(ai[i]); } - LispObject lispAiVector = new SimpleVector(lispAi); - SimpleString[] lispAs = new SimpleString[as.length]; + final LispObject lispAiVector = new SimpleVector(lispAi); + final SimpleString[] lispAs = new SimpleString[as.length]; for (int i = 0; i < as.length; i++) { lispAs[i] = new SimpleString(as[i]); } - LispObject lispAsVector = new SimpleVector(lispAs); - LispObject[] args = new LispObject[] //FIXME: count -> seq_num - { data, new JavaObject(o), lispAiVector, lispAsVector, internKeyword(s), count }; + final LispObject lispAsVector = new SimpleVector(lispAs); + LispObject[] args = + new LispObject[] //FIXME: count -> seq_num + { data, + new JavaObject(o), + lispAiVector, + lispAsVector, + internKeyword(s), + count }; f.execute(args); } } From mevenson at common-lisp.net Wed Nov 10 21:13:44 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 10 Nov 2010 16:13:44 -0500 Subject: [armedbear-cvs] r13016 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Nov 10 16:13:42 2010 New Revision: 13016 Log: Improve docstring for SYS:ZIP. Modified: trunk/abcl/src/org/armedbear/lisp/zip.java Modified: trunk/abcl/src/org/armedbear/lisp/zip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/zip.java (original) +++ trunk/abcl/src/org/armedbear/lisp/zip.java Wed Nov 10 16:13:42 2010 @@ -44,17 +44,22 @@ import java.util.zip.ZipEntry; import java.util.zip.ZipOutputStream; -// ### zip pathname pathnames + at DocString(name="zip", + args="pathname pathnames &optional topdir", + doc="Creates a zip archive at PATHNAME whose entries enumerated via the list of PATHNAMES.\n" + + "If the optional TOPDIR argument is specified, the archive will " + + "preserve the hierarchy of PATHNAMES relative to TOPDIR. Without " + + "TOPDIR, there will be no sub-directories in the archive, i.e. it will " + + "be flat.") public final class zip extends Primitive { private zip() { - super("zip", PACKAGE_SYS, true, "pathname pathnames &optional topdir"); + super("zip", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject first, LispObject second) - { Pathname zipfilePathname = coerceToPathname(first); byte[] buffer = new byte[4096]; From mevenson at common-lisp.net Wed Nov 10 22:23:06 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 10 Nov 2010 17:23:06 -0500 Subject: [armedbear-cvs] r13017 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Nov 10 17:23:05 2010 New Revision: 13017 Log: Check type in MAKE-PATHNAME for :DIRECTORY components. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Wed Nov 10 17:23:05 2010 @@ -1244,7 +1244,18 @@ } else if (value == Keyword.WILD) { directory = list(Keyword.ABSOLUTE, Keyword.WILD); } else { - directory = value; + // a valid pathname directory is a string, a list of strings, nil, :wild, :unspecific + // ??? would be nice to (deftype pathname-arg () + // '(or (member :wild :unspecific) string (and cons ,(mapcar ... + // Is this possible? + if ((value instanceof Cons + // XXX check that the elements of a list are themselves valid + || value == Keyword.UNSPECIFIC + || value.equals(NIL))) { + directory = value; + } else { + error(new TypeError("DIRECTORY argument not a string, list of strings, nil, :WILD, or :UNSPECIFIC.", value, NIL)); + } } } else if (key == Keyword.NAME) { name = value; From ehuelsmann at common-lisp.net Thu Nov 11 08:20:17 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 11 Nov 2010 03:20:17 -0500 Subject: [armedbear-cvs] r13018 - public_html Message-ID: Author: ehuelsmann Date: Thu Nov 11 03:20:13 2010 New Revision: 13018 Log: Re-order testimonials according to date. Modified: public_html/testimonials.shtml Modified: public_html/testimonials.shtml ============================================================================== --- public_html/testimonials.shtml (original) +++ public_html/testimonials.shtml Thu Nov 11 03:20:13 2010 @@ -28,6 +28,17 @@

    Testimonials

    +
    Alessio Stalla - November, 2010 +
    +
    With my Java background and my love for Lisp, I've found ABCL to be the ideal choice for my open source projects, in particular: +
      +
    • DynaSpring (http://code.google.com/p/dynaspring/), a Lisp-based DSL for the Spring framework: it replaces the ugly-ugly XML with our beloved parentheses, bringing new features to Spring (conditional evaluation, modularity constructs, etc.) and making it much more user-extensible;
      • +
    • Snow (http://common-lisp.net/project/snow/), a declarative GUI language in the vein of XUL, but obviously Lisp-based, targeting Swing. While still lacking many things, it combines a Lisp DSL with existing Java libraries to concisely describe the structure and layout of the GUI, and to make it easy to connect the UI with the application, thanks to its integration with Cells;
      • +
    • and all the other experimental, unreleased stuff I do as a hobby (mainly related to web development and enterprise application development).
      • +
    +For me ABCL's selling point is of course its interoperability with Java and the consequent access to Java libraries, but I also appreciate its simplicity, portability (even FASLs are cross-platform, thanks to the JVM), and last but not least, the small but vibrant and helpful community. +
    +
    David Kirkman (Astronomer at University of California, San Diego) - June 7, 2010
    @@ -75,17 +86,6 @@ the development of this terrific package, a big THANK YOU!!!" -
    Alessio Stalla - November, 2010 -
    -
    With my Java background and my love for Lisp, I've found ABCL to be the ideal choice for my open source projects, in particular: -
      -
    • DynaSpring (http://code.google.com/p/dynaspring/), a Lisp-based DSL for the Spring framework: it replaces the ugly-ugly XML with our beloved parentheses, bringing new features to Spring (conditional evaluation, modularity constructs, etc.) and making it much more user-extensible;
      • -
    • Snow (http://common-lisp.net/project/snow/), a declarative GUI language in the vein of XUL, but obviously Lisp-based, targeting Swing. While still lacking many things, it combines a Lisp DSL with existing Java libraries to concisely describe the structure and layout of the GUI, and to make it easy to connect the UI with the application, thanks to its integration with Cells;
      • -
    • and all the other experimental, unreleased stuff I do as a hobby (mainly related to web development and enterprise application development).
      • -
    -For me ABCL's selling point is of course its interoperability with Java and the consequent access to Java libraries, but I also appreciate its simplicity, portability (even FASLs are cross-platform, thanks to the JVM), and last but not least, the small but vibrant and helpful community. -
    -
    Hunter Monroe
    "Maxima algebraic computation software compiles with ABCL. The test suite @@ -93,7 +93,8 @@ percent of the test suite is passed successfully, although some individual tests crash the suite. If you want to compile Maxima with ABCL lisp, check out the Maxima source code and following the instructions in INSTALL.lisp." -
    +

    Editor's note: the Maxima test suite runs without crashes and +succesfully completes without failures as of 10-11-2010.

    Ted Kosan
    From ehuelsmann at common-lisp.net Thu Nov 11 10:46:46 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 11 Nov 2010 05:46:46 -0500 Subject: [armedbear-cvs] r13019 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 11 05:46:42 2010 New Revision: 13019 Log: Don't manually iterate through subforms, use available function for it. 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 Nov 11 05:46:42 2010 @@ -2752,8 +2752,7 @@ (emit-push-current-thread) (emit-getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register) - (dolist (subform subforms) - (compile-form subform nil nil)) + (compile-progn-body subforms nil nil) ;; Restore multiple values returned by first subform. (emit-push-current-thread) (aload values-register) From ehuelsmann at common-lisp.net Thu Nov 11 11:55:57 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 11 Nov 2010 06:55:57 -0500 Subject: [armedbear-cvs] r13020 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 11 06:55:54 2010 New Revision: 13020 Log: Another Don't manually iterate through subforms, use available function for it. 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 Nov 11 06:55:54 2010 @@ -6561,9 +6561,7 @@ (emit-getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register) (let ((*register* *register*)) - (dolist (subform cleanup-forms) - (compile-form subform nil nil))) - (maybe-emit-clear-values cleanup-forms) + (compile-progn-body cleanup-forms nil nil)) (emit-push-current-thread) (aload values-register) (emit-putfield +lisp-thread+ "_values" +lisp-object-array+) From ehuelsmann at common-lisp.net Thu Nov 11 12:40:41 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 11 Nov 2010 07:40:41 -0500 Subject: [armedbear-cvs] r13021 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 11 07:40:40 2010 New Revision: 13021 Log: Reduce the number of ATHROW instructions executed while running the Maxima test suite by ~60%. Note: because we don't generate stack dumps on our ControlTransfer exception derivatives, we only save 2% execution time. 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 Nov 11 07:40:40 2010 @@ -2997,8 +2997,7 @@ (let ((*blocks* (cons block *blocks*))) (compile-progn-body (cdddr form) target)) (when bind-special-p - (restore-environment-and-make-handler (m-v-b-environment-register block) - label-START)))) + (restore-dynamic-environment (m-v-b-environment-register block))))) (defun propagate-vars (block) (let ((removed '())) @@ -3355,8 +3354,7 @@ (let ((*blocks* (cons block *blocks*))) (compile-progn-body (cddr form) target representation))) (when specialp - (restore-environment-and-make-handler (let-environment-register block) - label-START)))) + (restore-dynamic-environment (let-environment-register block))))) (defknown p2-locally-node (t t t) t) (defun p2-locally-node (block target representation) @@ -3379,7 +3377,9 @@ (END-BLOCK (gensym)) (RETHROW (gensym)) (EXIT (gensym)) - (must-clear-values nil)) + (must-clear-values nil) + (specials-register (when (tagbody-non-local-go-p block) + (allocate-register)))) ;; Scan for tags. (dolist (tag (tagbody-tags block)) (push tag *visible-tags*)) @@ -3391,6 +3391,8 @@ (emit 'dup) (emit-invokespecial-init +lisp-object+ '()) (emit-new-closure-binding (tagbody-id-variable block))) + (when (tagbody-non-local-go-p block) + (save-dynamic-environment specials-register)) (label BEGIN-BLOCK) (do* ((rest body (cdr rest)) (subform (car rest) (car rest))) @@ -3427,6 +3429,7 @@ (aload go-register) (emit-getfield +lisp-go+ "tag" +lisp-object+) ; Stack depth is still 1. (astore tag-register) + (restore-dynamic-environment specials-register) ;; Don't actually generate comparisons for tags ;; to which there is no non-local GO instruction (dolist (tag (remove-if-not #'tag-used-non-locally @@ -3572,7 +3575,9 @@ (*register* *register*) (BEGIN-BLOCK (gensym)) (END-BLOCK (gensym)) - (BLOCK-EXIT (block-exit block))) + (BLOCK-EXIT (block-exit block)) + (specials-register (when (block-non-local-return-p block) + (allocate-register)))) (setf (block-target block) target) (when (block-id-variable block) ;; we have a block variable; that should be a closure variable @@ -3583,6 +3588,8 @@ (emit-new-closure-binding (block-id-variable block))) (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) + (when (block-non-local-return-p block) + (save-dynamic-environment specials-register)) (label BEGIN-BLOCK) ; Start of protected range, for non-local returns ;; Implicit PROGN. (compile-progn-body (cddr (block-form block)) target) @@ -3610,6 +3617,7 @@ (emit-move-to-variable (block-id-variable block)) (emit 'athrow) (label THIS-BLOCK) + (restore-dynamic-environment specials-register) (emit-getfield +lisp-return+ "result" +lisp-object+) (emit-move-from-stack target) ; Stack depth is 0. ;; Finally... @@ -3731,7 +3739,7 @@ ;; Implicit PROGN. (let ((*blocks* (cons block *blocks*))) (compile-progn-body (cdddr form) target representation)) - (restore-environment-and-make-handler environment-register label-START))) + (restore-dynamic-environment environment-register))) (defun p2-quote (form target representation) (aver (or (null representation) (eq representation :boolean))) @@ -6448,7 +6456,8 @@ (THROW-HANDLER (gensym)) (RETHROW (gensym)) (DEFAULT-HANDLER (gensym)) - (EXIT (gensym))) + (EXIT (gensym)) + (specials-register (allocate-register))) (compile-form (second form) tag-register nil) ; Tag. (emit-push-current-thread) (aload tag-register) @@ -6456,6 +6465,7 @@ (lisp-object-arg-types 1) nil) (let ((*blocks* (cons block *blocks*))) ; Stack depth is 0. + (save-dynamic-environment specials-register) (label BEGIN-PROTECTED-RANGE) ; Start of protected range. (compile-progn-body (cddr form) target) ; Implicit PROGN. (label END-PROTECTED-RANGE) ; End of protected range. @@ -6468,6 +6478,7 @@ ;; 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 RETHROW) ; Stack depth is 1. + (restore-dynamic-environment specials-register) (emit-push-current-thread) (emit-invokevirtual +lisp-throw+ "getResult" (list +lisp-thread+) +lisp-object+) @@ -6533,6 +6544,7 @@ (exception-register (allocate-register)) (result-register (allocate-register)) (values-register (allocate-register)) + (specials-register (allocate-register)) (BEGIN-PROTECTED-RANGE (gensym)) (END-PROTECTED-RANGE (gensym)) (HANDLER (gensym)) @@ -6541,6 +6553,7 @@ (emit-clear-values) (let* ((*blocks* (cons block *blocks*))) + (save-dynamic-environment specials-register) (label BEGIN-PROTECTED-RANGE) (compile-form protected-form result-register nil) (unless (single-valued-p protected-form) @@ -6560,6 +6573,7 @@ (emit-push-current-thread) (emit-getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register) + (restore-dynamic-environment specials-register) (let ((*register* *register*)) (compile-progn-body cleanup-forms nil nil)) (emit-push-current-thread) @@ -6907,8 +6921,7 @@ (compile-progn-body body 'stack) (when (compiland-environment-register compiland) - (restore-environment-and-make-handler - (compiland-environment-register compiland) label-START)) + (restore-dynamic-environment (compiland-environment-register compiland))) (unless *code* (emit-push-nil)) From ehuelsmann at common-lisp.net Thu Nov 11 20:52:34 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 11 Nov 2010 15:52:34 -0500 Subject: [armedbear-cvs] r13022 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 11 15:52:32 2010 New Revision: 13022 Log: Small simplification in MAKE-CONSTRUCTOR arguments. Patch by: astalla. 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 Nov 11 15:52:32 2010 @@ -793,8 +793,11 @@ (defun emit-read-from-string (object) (emit-constructor-lambda-list object)) -(defun make-constructor (super lambda-name args) +(defun make-constructor (class) (let* ((*compiler-debug* nil) + (super (class-file-superclass class)) + (lambda-name (abcl-class-file-lambda-name class)) + (args (abcl-class-file-lambda-list class)) ;; We don't normally need to see debugging output for constructors. (method (make-method :constructor :void nil :flags '(:public))) @@ -915,9 +918,7 @@ The compiler calls this function to indicate it doesn't want to extend the class any further." - (class-add-method class (make-constructor (class-file-superclass class) - (abcl-class-file-lambda-name class) - (abcl-class-file-lambda-list class))) + (class-add-method class (make-constructor class)) (finalize-class-file class) (write-class-file class stream)) From ehuelsmann at common-lisp.net Sun Nov 14 11:23:57 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Nov 2010 06:23:57 -0500 Subject: [armedbear-cvs] r13023 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Nov 14 06:23:55 2010 New Revision: 13023 Log: With 0.23 branched, increase the version number on trunk. Modified: trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Sun Nov 14 06:23:55 2010 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.23.0-dev"; + return "0.24.0-dev"; } public static void main(String args[]) { From mevenson at common-lisp.net Mon Nov 15 15:05:46 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 15 Nov 2010 10:05:46 -0500 Subject: [armedbear-cvs] r13024 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Mon Nov 15 10:05:39 2010 New Revision: 13024 Log: Fix loading from pathnames with '+' in directory pathname re #110. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/test/lisp/abcl/jar-pathname.lisp 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 Mon Nov 15 10:05:39 2010 @@ -199,6 +199,8 @@ String s; try { s = URLDecoder.decode(url.getPath(), "UTF-8"); + // But rencode \SPACE as '+' + s = s.replace(' ', '+'); } catch (java.io.UnsupportedEncodingException uee) { // Can't happen: every Java is supposed to support // at least UTF-8 encoding Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Mon Nov 15 10:05:39 2010 @@ -39,29 +39,32 @@ (compile-file "foo.lisp") (compile-file "bar.lisp") (compile-file "eek.lisp") - (let* ((dir (merge-pathnames "tmp/" *abcl-test-directory*)) - (sub (merge-pathnames "a/b/" dir))) - (when (probe-directory dir) - (delete-directory-and-files dir)) - (ensure-directories-exist sub) - (sys:unzip (merge-pathnames "foo.abcl") - dir) - (sys:unzip (merge-pathnames "foo.abcl") - sub) + (let* ((tmpdir (merge-pathnames "tmp/" *abcl-test-directory*)) + (subdirs + (mapcar (lambda (p) (merge-pathnames p tmpdir)) + '("a/b/" "d/e+f/"))) + (sub1 (first subdirs)) + (sub2 (second subdirs))) + (when (probe-directory tmpdir) + (delete-directory-and-files tmpdir)) + (mapcar (lambda (p) (ensure-directories-exist p)) subdirs) + (sys:unzip (merge-pathnames "foo.abcl") tmpdir) + (sys:unzip (merge-pathnames "foo.abcl") sub1) (cl-fad-copy-file (merge-pathnames "bar.abcl") - (merge-pathnames "bar.abcl" dir)) + (merge-pathnames "bar.abcl" tmpdir)) (cl-fad-copy-file (merge-pathnames "bar.abcl") - (merge-pathnames "bar.abcl" sub)) + (merge-pathnames "bar.abcl" sub1)) + (cl-fad-copy-file (merge-pathnames "bar.abcl") + (merge-pathnames "bar.abcl" sub2)) (cl-fad-copy-file (merge-pathnames "eek.lisp") - (merge-pathnames "eek.lisp" dir)) + (merge-pathnames "eek.lisp" tmpdir)) (cl-fad-copy-file (merge-pathnames "eek.lisp") - (merge-pathnames "eek.lisp" sub)) + (merge-pathnames "eek.lisp" sub1)) (sys:zip (merge-pathnames "baz.jar") - (append - (directory (merge-pathnames "*" dir)) - (directory (merge-pathnames "*" sub))) - dir) - (delete-directory-and-files dir))) + (loop :for p :in (list tmpdir sub1 sub2) + :appending (directory (merge-pathnames "*" p))) + tmpdir) + #+nil (delete-directory-and-files dir))) (setf *jar-file-init* t)) (defmacro with-jar-file-init (&rest body) @@ -121,6 +124,11 @@ (load "jar:file:baz.jar!/a/b/eek.lisp")) t) +(deftest jar-pathname.load.11 + (with-jar-file-init + (load "jar:file:baz.jar!/d/e+f/bar.abcl")) + t) + ;;; wrapped in PROGN for easy disabling without a network connection ;;; XXX come up with a better abstraction @@ -131,43 +139,43 @@ `(load (format nil "~A~A" *url-jar-pathname-base* ,path))) (progn - (deftest jar-pathname.load.11 + (deftest jar-pathname.load.http.1 (load-url-relative "foo") t) - (deftest jar-pathname.load.12 + (deftest jar-pathname.load.http.2 (load-url-relative "bar") t) - (deftest jar-pathname.load.13 + (deftest jar-pathname.load.http.3 (load-url-relative "bar.abcl") t) - (deftest jar-pathname.load.14 + (deftest jar-pathname.load.http.4 (load-url-relative "eek") t) - (deftest jar-pathname.load.15 + (deftest jar-pathname.load.http.5 (load-url-relative "eek.lisp") t) - (deftest jar-pathname.load.16 + (deftest jar-pathname.load.http.6 (load-url-relative "a/b/foo") t) - (deftest jar-pathname.load.17 + (deftest jar-pathname.load.http.7 (load-url-relative "a/b/bar") t) - (deftest jar-pathname.load.18 + (deftest jar-pathname.load.http.8 (load-url-relative "a/b/bar.abcl") t) - (deftest jar-pathname.load.19 + (deftest jar-pathname.load.http.9 (load-url-relative "a/b/eek") t) - (deftest jar-pathname.load.20 + (deftest jar-pathname.load.http.10 (load-url-relative "a/b/eek.lisp") t)) @@ -192,7 +200,8 @@ (deftest jar-pathname.probe-file.4 (with-jar-file-init (probe-file "jar:file:baz.jar!/a/b")) - nil) + #p#.(format nil "jar:file:~Abaz.jar!/a/b/" + (namestring *abcl-test-directory*))) (deftest jar-pathname.probe-file.5 (with-jar-file-init @@ -200,6 +209,12 @@ #p#.(format nil "jar:file:~Abaz.jar!/a/b/" (namestring *abcl-test-directory*))) +(deftest jar-pathname.probe-file.6 + (with-jar-file-init + (probe-file "jar:file:baz.jar!/d/e+f/bar.abcl")) + #p#.(format nil "jar:file:~Abaz.jar!/d/e+f/bar.abcl" + (namestring *abcl-test-directory*))) + (deftest jar-pathname.merge-pathnames.1 (merge-pathnames "/bar.abcl" #p"jar:file:baz.jar!/foo") From astalla at common-lisp.net Tue Nov 16 19:40:04 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 16 Nov 2010 14:40:04 -0500 Subject: [armedbear-cvs] r13025 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Nov 16 14:40:03 2010 New Revision: 13025 Log: Added with-code-to-method to pass2 to compile the constructor and, in the future, the static initializer. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm-class-file.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 Tue Nov 16 14:40:03 2010 @@ -524,15 +524,15 @@ (or (when (fixnum-type-p declared-type) 'FIXNUM) (find-if #'(lambda (type) (eq type declared-type)) - '(SYMBOL CHARACTER CONS HASH-TABLE)) - (find-if #'(lambda (type) (subtypep declared-type type)) - '(STRING VECTOR STREAM))))) + '(SYMBOL CHARACTER CONS HASH-TABLE)) + (find-if #'(lambda (type) (subtypep declared-type type)) + '(STRING VECTOR STREAM))))) (defknown generate-type-check-for-variable (t) t) (defun generate-type-check-for-variable (variable) - (let ((type-to-use - (find-type-for-type-check (variable-declared-type variable)))) + (let ((type-to-use + (find-type-for-type-check (variable-declared-type variable)))) (when type-to-use (generate-instanceof-type-check-for-variable variable type-to-use)))) @@ -640,9 +640,9 @@ (defun compile-forms-and-maybe-emit-clear-values (&rest forms-and-compile-args) (let ((forms-for-emit-clear - (loop for (form arg1 arg2) on forms-and-compile-args by #'cdddr - do (compile-form form arg1 arg2) - collecting form))) + (loop for (form arg1 arg2) on forms-and-compile-args by #'cdddr + do (compile-form form arg1 arg2) + collecting form))) (apply #'maybe-emit-clear-values forms-for-emit-clear))) (defknown emit-unbox-fixnum () t) @@ -748,8 +748,8 @@ (let* ((op (car form)) (args (cdr form)) (ok (if minimum - (>= (length args) n) - (= (length args) n)))) + (>= (length args) n) + (= (length args) n)))) (declare (type boolean ok)) (unless ok (funcall (if (eq (symbol-package op) +cl-package+) @@ -795,120 +795,127 @@ (defun make-constructor (class) (let* ((*compiler-debug* nil) + (method (make-method :constructor :void nil + :flags '(:public))) + ;; We don't normally need to see debugging output for constructors. (super (class-file-superclass class)) (lambda-name (abcl-class-file-lambda-name class)) (args (abcl-class-file-lambda-list class)) - ;; We don't normally need to see debugging output for constructors. - (method (make-method :constructor :void nil - :flags '(:public))) - (code (method-add-code method)) req-params-register opt-params-register key-params-register rest-p keys-p - more-keys-p - (*code* ()) - (*current-code-attribute* code)) - (setf (code-max-locals code) 1) - (unless (eq super +lisp-compiled-primitive+) - (multiple-value-bind - (req opt key key-p rest - allow-other-keys-p) - (parse-lambda-list args) - (setf rest-p rest - more-keys-p allow-other-keys-p - keys-p key-p) - (macrolet - ((parameters-to-array ((param params register) &body body) - (let ((count-sym (gensym))) - `(progn - (emit-push-constant-int (length ,params)) - (emit-anewarray +lisp-closure-parameter+) - (astore (setf ,register (code-max-locals code))) - (incf (code-max-locals code)) - (do* ((,count-sym 0 (1+ ,count-sym)) - (,params ,params (cdr ,params)) - (,param (car ,params) (car ,params))) - ((endp ,params)) - (declare (ignorable ,param)) - (aload ,register) - (emit-push-constant-int ,count-sym) - (emit-new +lisp-closure-parameter+) - (emit 'dup) - , at body - (emit 'aastore)))))) - ;; process required args - (parameters-to-array (ignore req req-params-register) - (emit-push-t) ;; we don't need the actual symbol - (emit-invokespecial-init +lisp-closure-parameter+ - (list +lisp-symbol+))) - - (parameters-to-array (param opt opt-params-register) - (emit-push-t) ;; we don't need the actual variable-symbol - (emit-read-from-string (second param)) ;; initform - (if (null (third param)) ;; supplied-p - (emit-push-nil) - (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit-getstatic +lisp-closure+ "OPTIONAL" :int) - (emit-invokespecial-init +lisp-closure-parameter+ - (list +lisp-symbol+ +lisp-object+ - +lisp-object+ :int))) - - (parameters-to-array (param key key-params-register) - (let ((keyword (fourth param))) - (if (keywordp keyword) - (progn - (emit 'ldc (pool-string (symbol-name keyword))) - (emit-invokestatic +lisp+ "internKeyword" - (list +java-string+) +lisp-symbol+)) - ;; symbol is not really a keyword; yes, that's allowed! - (progn - (emit 'ldc (pool-string (symbol-name keyword))) - (emit 'ldc (pool-string - (package-name (symbol-package keyword)))) - (emit-invokestatic +lisp+ "internInPackage" - (list +java-string+ +java-string+) - +lisp-symbol+)))) - (emit-push-t) ;; we don't need the actual variable-symbol - (emit-read-from-string (second (car key))) - (if (null (third param)) - (emit-push-nil) - (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit-invokespecial-init +lisp-closure-parameter+ - (list +lisp-symbol+ +lisp-symbol+ - +lisp-object+ +lisp-object+)))))) - (aload 0) ;; this - (cond ((eq super +lisp-compiled-primitive+) - (emit-constructor-lambda-name lambda-name) - (emit-constructor-lambda-list args) - (emit-invokespecial-init super (lisp-object-arg-types 2))) - ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME - (aload req-params-register) - (aload opt-params-register) - (aload key-params-register) - (if keys-p - (emit-push-t) - (emit-push-nil-symbol)) - (if rest-p - (emit-push-t) - (emit-push-nil-symbol)) - (if more-keys-p - (emit-push-t) - (emit-push-nil-symbol)) - (emit-invokespecial-init super - (list +lisp-closure-parameter-array+ - +lisp-closure-parameter-array+ - +lisp-closure-parameter-array+ - +lisp-symbol+ - +lisp-symbol+ +lisp-symbol+))) - (t - (aver nil))) - (setf *code* (append *static-code* *code*)) - (emit 'return) - (setf (code-code code) *code*) + more-keys-p) + (with-code-to-method (class method) + (allocate-register) + (unless (eq super +lisp-compiled-primitive+) + (multiple-value-bind + (req opt key key-p rest + allow-other-keys-p) + (parse-lambda-list args) + (setf rest-p rest + more-keys-p allow-other-keys-p + keys-p key-p) + (macrolet + ((parameters-to-array ((param params register) &body body) + (let ((count-sym (gensym))) + `(progn + (emit-push-constant-int (length ,params)) + (emit-anewarray +lisp-closure-parameter+) + (astore (setf ,register *registers-allocated*)) + (allocate-register) + (do* ((,count-sym 0 (1+ ,count-sym)) + (,params ,params (cdr ,params)) + (,param (car ,params) (car ,params))) + ((endp ,params)) + (declare (ignorable ,param)) + (aload ,register) + (emit-push-constant-int ,count-sym) + (emit-new +lisp-closure-parameter+) + (emit 'dup) + , at body + (emit 'aastore)))))) + ;; process required args + (parameters-to-array (ignore req req-params-register) + (emit-push-t) ;; we don't need the actual symbol + (emit-invokespecial-init +lisp-closure-parameter+ + (list +lisp-symbol+))) + + (parameters-to-array (param opt opt-params-register) + (emit-push-t) ;; we don't need the actual variable-symbol + (emit-read-from-string (second param)) ;; initform + (if (null (third param)) ;; supplied-p + (emit-push-nil) + (emit-push-t)) ;; we don't need the actual supplied-p symbol + (emit-getstatic +lisp-closure+ "OPTIONAL" :int) + (emit-invokespecial-init +lisp-closure-parameter+ + (list +lisp-symbol+ +lisp-object+ + +lisp-object+ :int))) + + (parameters-to-array (param key key-params-register) + (let ((keyword (fourth param))) + (if (keywordp keyword) + (progn + (emit 'ldc (pool-string (symbol-name keyword))) + (emit-invokestatic +lisp+ "internKeyword" + (list +java-string+) +lisp-symbol+)) + ;; symbol is not really a keyword; yes, that's allowed! + (progn + (emit 'ldc (pool-string (symbol-name keyword))) + (emit 'ldc (pool-string + (package-name (symbol-package keyword)))) + (emit-invokestatic +lisp+ "internInPackage" + (list +java-string+ +java-string+) + +lisp-symbol+)))) + (emit-push-t) ;; we don't need the actual variable-symbol + (emit-read-from-string (second (car key))) + (if (null (third param)) + (emit-push-nil) + (emit-push-t)) ;; we don't need the actual supplied-p symbol + (emit-invokespecial-init +lisp-closure-parameter+ + (list +lisp-symbol+ +lisp-symbol+ + +lisp-object+ +lisp-object+)))))) + (aload 0) ;; this + (cond ((eq super +lisp-compiled-primitive+) + (emit-constructor-lambda-name lambda-name) + (emit-constructor-lambda-list args) + (emit-invokespecial-init super (lisp-object-arg-types 2))) + ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME + (aload req-params-register) + (aload opt-params-register) + (aload key-params-register) + (if keys-p + (emit-push-t) + (emit-push-nil-symbol)) + (if rest-p + (emit-push-t) + (emit-push-nil-symbol)) + (if more-keys-p + (emit-push-t) + (emit-push-nil-symbol)) + (emit-invokespecial-init super + (list +lisp-closure-parameter-array+ + +lisp-closure-parameter-array+ + +lisp-closure-parameter-array+ + +lisp-symbol+ + +lisp-symbol+ +lisp-symbol+))) + (t + (sys::%format t "unhandled superclass ~A for ~A~%" + super + (abcl-class-file-class-name class)) + (aver nil)))) method)) +(defun make-static-initializer (class) + (let ((*compiler-debug* nil) + (method (make-method :static-initializer + :void nil :flags '(:public :static)))) + ;; We don't normally need to see debugging output for . + (with-code-to-method (class method) + (setf (code-max-locals *current-code-attribute*) 0) + (emit 'return) + method))) (defvar *source-line-number* nil) @@ -918,7 +925,8 @@ The compiler calls this function to indicate it doesn't want to extend the class any further." - (class-add-method class (make-constructor class)) + (with-code-to-method (class (abcl-class-file-constructor class)) + (emit 'return)) (finalize-class-file class) (write-class-file class stream)) @@ -950,9 +958,9 @@ (defvar *declare-inline* nil) (defmacro declare-with-hashtable (declared-item hashtable hashtable-var - item-var &body body) + item-var &body body) `(let* ((,hashtable-var ,hashtable) - (,item-var (gethash1 ,declared-item ,hashtable-var))) + (,item-var (gethash1 ,declared-item ,hashtable-var))) (declare (type hash-table ,hashtable-var)) (unless ,item-var , at body) @@ -1086,8 +1094,8 @@ the value of the object can be loaded. Objects may be coalesced based on the equality indicator in the `serialization-table'. -Code to restore the serialized object is inserted into `*code' or -`*static-code*' if `*declare-inline*' is non-nil. +Code to restore the serialized object is inserted into the current method or +the constructor if `*declare-inline*' is non-nil. " ;; TODO: rewrite to become EMIT-LOAD-EXTERNALIZED-OBJECT which ;; - instead of returning the name of the field - returns the type @@ -1117,23 +1125,23 @@ (cond ((not *file-compilation*) - (let ((*code* *static-code*)) + (with-code-to-method + (*class-file* (abcl-class-file-constructor *class-file*)) (remember field-name object) (emit 'ldc (pool-string field-name)) (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) (when (not (eq field-type +lisp-object+)) (emit-checkcast field-type)) - (emit-putstatic *this-class* field-name field-type) - (setf *static-code* *code*))) + (emit-putstatic *this-class* field-name field-type))) (*declare-inline* (funcall dispatch-fn object) (emit-putstatic *this-class* field-name field-type)) (t - (let ((*code* *static-code*)) + (with-code-to-method + (*class-file* (abcl-class-file-constructor *class-file*)) (funcall dispatch-fn object) - (emit-putstatic *this-class* field-name field-type) - (setf *static-code* *code*)))) + (emit-putstatic *this-class* field-name field-type)))) (emit-getstatic *this-class* field-name field-type) (when cast @@ -1163,30 +1171,26 @@ (declare-object-as-string symbol) (declare-object symbol)) class *this-class*)) - (let (saved-code) - (let ((*code* (if *declare-inline* *code* *static-code*))) - (if (eq class *this-class*) - (progn ;; generated by the DECLARE-OBJECT*'s above - (emit-getstatic class name +lisp-object+) - (emit-checkcast +lisp-symbol+)) - (emit-getstatic class name +lisp-symbol+)) - (emit-invokevirtual +lisp-symbol+ - (if setf - "getSymbolSetfFunctionOrDie" - "getSymbolFunctionOrDie") - nil +lisp-object+) - ;; make sure we're not cacheing a proxied function - ;; (AutoloadedFunctionProxy) by allowing it to resolve itself - (emit-invokevirtual +lisp-object+ - "resolve" nil +lisp-object+) - (emit-putstatic *this-class* f +lisp-object+) - (if *declare-inline* - (setf saved-code *code*) - (setf *static-code* *code*)) - (setf (gethash symbol ht) f)) - (when *declare-inline* - (setf *code* saved-code)) - f)))) + (with-code-to-method (*class-file* + (if *declare-inline* *method* + (abcl-class-file-constructor *class-file*))) + (if (eq class *this-class*) + (progn ;; generated by the DECLARE-OBJECT*'s above + (emit-getstatic class name +lisp-object+) + (emit-checkcast +lisp-symbol+)) + (emit-getstatic class name +lisp-symbol+)) + (emit-invokevirtual +lisp-symbol+ + (if setf + "getSymbolSetfFunctionOrDie" + "getSymbolFunctionOrDie") + nil +lisp-object+) + ;; make sure we're not cacheing a proxied function + ;; (AutoloadedFunctionProxy) by allowing it to resolve itself + (emit-invokevirtual +lisp-object+ + "resolve" nil +lisp-object+) + (emit-putstatic *this-class* f +lisp-object+) + (setf (gethash symbol ht) f)) + f))) (defknown declare-setf-function (name) string) (defun declare-setf-function (name) @@ -1198,17 +1202,17 @@ (declare-with-hashtable local-function *declared-functions* ht g (setf g (symbol-name (gensym "LFUN"))) - (let* ((class-name (abcl-class-file-class-name - (local-function-class-file local-function))) - (*code* *static-code*)) - ;; fixme *declare-inline* - (declare-field g +lisp-object+) - (emit-new class-name) - (emit 'dup) - (emit-invokespecial-init class-name '()) - (emit-putstatic *this-class* g +lisp-object+) - (setf *static-code* *code*) - (setf (gethash local-function ht) g)))) + (let ((class-name (abcl-class-file-class-name + (local-function-class-file local-function)))) + (with-code-to-method + (*class-file* (abcl-class-file-constructor *class-file*)) + ;; fixme *declare-inline* + (declare-field g +lisp-object+) + (emit-new class-name) + (emit 'dup) + (emit-invokespecial-init class-name '()) + (emit-putstatic *this-class* g +lisp-object+) + (setf (gethash local-function ht) g))))) (defknown declare-object-as-string (t) string) @@ -1221,45 +1225,39 @@ ;; The solution is to rewrite externalize-object to ;; EMIT-LOAD-EXTERNALIZED-OBJECT, which serializes *and* ;; emits the right loading code (not just de-serialization anymore) - (let (saved-code - (g (symbol-name (gensym "OBJSTR")))) - (let* ((s (with-output-to-string (stream) (dump-form obj stream))) - (*code* (if *declare-inline* *code* *static-code*))) + (let ((g (symbol-name (gensym "OBJSTR"))) + (s (with-output-to-string (stream) (dump-form obj stream)))) + (with-code-to-method + (*class-file* + (if *declare-inline* *method* + (abcl-class-file-constructor *class-file*))) ;; strings may contain evaluated bits which may depend on ;; previous statements (declare-field g +lisp-object+) (emit 'ldc (pool-string s)) (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+) - (emit-putstatic *this-class* g +lisp-object+) - (if *declare-inline* - (setf saved-code *code*) - (setf *static-code* *code*))) - (when *declare-inline* - (setf *code* saved-code)) + (emit-putstatic *this-class* g +lisp-object+)) g)) (defun declare-load-time-value (obj) (let ((g (symbol-name (gensym "LTV"))) - saved-code) - (let* ((s (with-output-to-string (stream) (dump-form obj stream))) - (*code* (if *declare-inline* *code* *static-code*))) - ;; The readObjectFromString call may require evaluation of - ;; lisp code in the string (think #.() syntax), of which the outcome - ;; may depend on something which was declared inline - (declare-field g +lisp-object+) - (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp+ "readObjectFromString" - (list +java-string+) +lisp-object+) - (emit-invokestatic +lisp+ "loadTimeValue" - (lisp-object-arg-types 1) +lisp-object+) - (emit-putstatic *this-class* g +lisp-object+) - (if *declare-inline* - (setf saved-code *code*) - (setf *static-code* *code*))) - (when *declare-inline* - (setf *code* saved-code)) - g)) + (s (with-output-to-string (stream) (dump-form obj stream)))) + (with-code-to-method + (*class-file* + (if *declare-inline* *method* + (abcl-class-file-constructor *class-file*))) + ;; The readObjectFromString call may require evaluation of + ;; lisp code in the string (think #.() syntax), of which the outcome + ;; may depend on something which was declared inline + (declare-field g +lisp-object+) + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp+ "readObjectFromString" + (list +java-string+) +lisp-object+) + (emit-invokestatic +lisp+ "loadTimeValue" + (lisp-object-arg-types 1) +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+)) + g)) (declaim (ftype (function (t) string) declare-object)) (defun declare-object (obj) @@ -1270,14 +1268,14 @@ (let ((g (symbol-name (gensym "OBJ")))) ;; fixme *declare-inline*? (remember g obj) - (let* ((*code* *static-code*)) + (with-code-to-method + (*class-file* (abcl-class-file-constructor *class-file*)) (declare-field g +lisp-object+) (emit 'ldc (pool-string g)) (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) - (emit-putstatic *this-class* g +lisp-object+) - (setf *static-code* *code*) - g))) + (emit-putstatic *this-class* g +lisp-object+)) + g)) (defknown compile-constant (t t t) t) (defun compile-constant (form target representation) @@ -1405,13 +1403,13 @@ (defmacro define-inlined-function (name params preamble-and-test &body body) (let* ((test (second preamble-and-test)) - (preamble (and test (first preamble-and-test))) - (test (or test (first preamble-and-test)))) + (preamble (and test (first preamble-and-test))) + (test (or test (first preamble-and-test)))) `(defun ,name ,params ,preamble (unless ,test - (compile-function-call , at params) - (return-from ,name)) + (compile-function-call , at params) + (return-from ,name)) , at body))) (defknown p2-predicate (t t t) t) @@ -1423,7 +1421,7 @@ (unboxed-method-name (cdr info))) (cond ((and boxed-method-name unboxed-method-name) (let ((arg (cadr form))) - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (ecase representation (:boolean (emit-invokevirtual +lisp-object+ @@ -1461,7 +1459,7 @@ (return-from compile-function-call-1 t)) (let ((s (gethash1 op (the hash-table *unary-operators*)))) (cond (s - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-invoke-method s target representation) t) (t @@ -1497,9 +1495,9 @@ (let ((arg1 (car args)) (arg2 (cadr args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + arg2 'stack nil) (emit-invokevirtual +lisp-object+ op - (lisp-object-arg-types 1) +lisp-object+) + (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -1550,7 +1548,7 @@ (arg1 (%car args)) (arg2 (%cadr args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + arg2 'stack nil) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1) @@ -1576,8 +1574,8 @@ (type2 (derive-compiler-type arg2))) (cond ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) (let ((label1 (gensym)) (label2 (gensym))) (emit 'if_icmpeq label1) @@ -1587,26 +1585,26 @@ (emit-push-true representation) (label label2))) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) - (emit-ifne-for-eql representation '(:int))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-ifne-for-eql representation '(:int))) ((fixnum-type-p type1) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) (emit 'swap) - (emit-ifne-for-eql representation '(:int))) + (emit-ifne-for-eql representation '(:int))) ((eq type2 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :char) - (emit-ifne-for-eql representation '(:char))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :char) + (emit-ifne-for-eql representation '(:char))) ((eq type1 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char + arg2 'stack nil) (emit 'swap) - (emit-ifne-for-eql representation '(:char))) + (emit-ifne-for-eql representation '(:char))) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (ecase representation (:boolean (emit-invokevirtual +lisp-object+ "eql" @@ -1694,9 +1692,9 @@ (let ((arg1 (first args)) (arg2 (second args)) (arg3 (third args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil - arg3 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil + arg3 'stack nil) (emit-invokestatic +lisp+ "getf" (lisp-object-arg-types 3) +lisp-object+) (fix-boxing representation nil) @@ -2061,7 +2059,7 @@ (common-rep (let ((LABEL1 (gensym)) (LABEL2 (gensym))) - (compile-forms-and-maybe-emit-clear-values + (compile-forms-and-maybe-emit-clear-values arg1 'stack common-rep arg2 'stack common-rep) (emit-numeric-comparison op common-rep LABEL1) @@ -2073,7 +2071,7 @@ (emit-move-from-stack target representation) (return-from p2-numeric-comparison)) ((fixnump arg2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-constant-int arg2) (emit-invokevirtual +lisp-object+ (case op @@ -2240,24 +2238,24 @@ (let ((tmpform (gensym))) `(let ((,tmpform ,form)) (when (check-arg-count ,tmpform 1) - (let ((arg (%cadr ,tmpform))) - (cond ((fixnum-type-p (derive-compiler-type arg)) - (compile-forms-and-maybe-emit-clear-values arg 'stack :int) - , at instructions) - (t - (p2-test-predicate ,tmpform ,predicate)))))))) + (let ((arg (%cadr ,tmpform))) + (cond ((fixnum-type-p (derive-compiler-type arg)) + (compile-forms-and-maybe-emit-clear-values arg 'stack :int) + , at instructions) + (t + (p2-test-predicate ,tmpform ,predicate)))))))) (defun p2-test-evenp (form) (p2-test-integer-predicate form "evenp" - (emit-push-constant-int 1) - (emit 'iand) - 'ifne)) + (emit-push-constant-int 1) + (emit 'iand) + 'ifne)) (defun p2-test-oddp (form) (p2-test-integer-predicate form "oddp" - (emit-push-constant-int 1) - (emit 'iand) - 'ifeq)) + (emit-push-constant-int 1) + (emit 'iand) + 'ifeq)) (defun p2-test-floatp (form) (p2-test-predicate form "floatp")) @@ -2270,10 +2268,10 @@ (let* ((arg (%cadr form)) (arg-type (derive-compiler-type arg))) (cond ((memq arg-type '(CONS LIST NULL)) - (compile-forms-and-maybe-emit-clear-values arg nil nil) + (compile-forms-and-maybe-emit-clear-values arg nil nil) :consequent) ((neq arg-type t) - (compile-forms-and-maybe-emit-clear-values arg nil nil) + (compile-forms-and-maybe-emit-clear-values arg nil nil) :alternate) (t (p2-test-predicate form "listp")))))) @@ -2340,10 +2338,10 @@ ((null test-form) :alternate) ((eq (derive-compiler-type test-form) 'BOOLEAN) - (compile-forms-and-maybe-emit-clear-values test-form 'stack :boolean) + (compile-forms-and-maybe-emit-clear-values test-form 'stack :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values test-form 'stack nil) + (compile-forms-and-maybe-emit-clear-values test-form 'stack nil) (emit-push-nil) 'if_acmpeq))) @@ -2374,7 +2372,7 @@ (let* ((arg1 (%cadr form)) (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack :char) + arg2 'stack :char) 'if_icmpne))) (defun p2-test-eq (form) @@ -2382,7 +2380,7 @@ (let ((arg1 (%cadr form)) (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + arg2 'stack nil) 'if_acmpne))) (defun p2-test-and (form) @@ -2411,38 +2409,38 @@ (type1 (derive-compiler-type arg1)) (type2 (derive-compiler-type arg2))) (cond ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) 'if_icmpne) ((and (eq type1 'CHARACTER) (eq type2 'CHARACTER)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack :char) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char + arg2 'stack :char) 'if_icmpne) ((eq type2 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :char) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :char) (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 'ifeq) ((eq type1 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char + arg2 'stack nil) (emit 'swap) (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 'ifeq) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 'ifeq) ((fixnum-type-p type1) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) (emit 'swap) (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (emit-invokevirtual +lisp-object+ "eql" (lisp-object-arg-types 1) :boolean) 'ifeq))))) @@ -2456,14 +2454,14 @@ (arg1 (%cadr form)) (arg2 (%caddr form))) (cond ((fixnum-type-p (derive-compiler-type arg2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ translated-op '(:int) :boolean)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (emit-invokevirtual +lisp-object+ translated-op (lisp-object-arg-types 1) :boolean))) @@ -2474,7 +2472,7 @@ (let ((arg1 (%cadr form)) (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + arg2 'stack nil) (emit-invokevirtual +lisp-object+ "typep" (lisp-object-arg-types 1) +lisp-object+) (emit-push-nil) @@ -2485,7 +2483,7 @@ (let ((arg1 (%cadr form)) (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + arg2 'stack nil) (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) :boolean) 'ifeq))) @@ -2495,7 +2493,7 @@ (let ((arg1 (%cadr form)) (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + arg2 'stack nil) (emit-invokestatic +lisp+ "memql" (lisp-object-arg-types 2) :boolean) 'ifeq))) @@ -2510,25 +2508,25 @@ (if (/= arg1 arg2) :consequent :alternate)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) 'if_icmpeq) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 'ifeq) ((fixnum-type-p type1) ;; FIXME Compile the args in reverse order and avoid the swap if ;; either arg is a fixnum or a lexical variable. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) (emit 'swap) (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (emit-invokevirtual +lisp-object+ "isNotEqualTo" (lisp-object-arg-types 1) :boolean) 'ifeq))))) @@ -2545,8 +2543,8 @@ (cond ((and (fixnump arg1) (fixnump arg2)) (if (funcall op arg1 arg2) :consequent :alternate)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) (ecase op (< 'if_icmpge) (<= 'if_icmpgt) @@ -2554,8 +2552,8 @@ (>= 'if_icmplt) (= 'if_icmpne))) ((and (java-long-type-p type1) (java-long-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) (emit 'lcmp) (ecase op (< 'ifge) @@ -2564,8 +2562,8 @@ (>= 'iflt) (= 'ifne))) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") @@ -2578,8 +2576,8 @@ ((fixnum-type-p type1) ;; FIXME We can compile the args in reverse order and avoid ;; the swap if either arg is a fixnum or a lexical variable. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) (emit 'swap) (emit-invokevirtual +lisp-object+ (ecase op @@ -2591,8 +2589,8 @@ '(:int) :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") @@ -2623,14 +2621,14 @@ ;; ERROR CHECKING HERE! (let ((arg1 (second arg)) (arg2 (third arg))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (emit 'if_acmpeq LABEL1))) ((eq (derive-compiler-type arg) 'BOOLEAN) - (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) (emit 'ifne LABEL1)) (t - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-push-nil) (emit 'if_acmpne LABEL1)))) (compile-form alternate target representation) @@ -2655,9 +2653,8 @@ (p2-if (list 'IF (%car args) consequent alternate) target representation)) (t (dolist (arg args) - (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) - (emit 'ifeq LABEL1) - ) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (emit 'ifeq LABEL1)) (compile-form consequent target representation) (emit 'goto LABEL2) (label LABEL1) @@ -2681,10 +2678,10 @@ (dolist (arg args) (let ((type (derive-compiler-type arg))) (cond ((eq type 'BOOLEAN) - (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) (emit 'ifeq LABEL1)) (t - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-push-nil) (emit 'if_acmpeq LABEL1))))) (compile-form alternate target representation) @@ -2707,7 +2704,7 @@ ((numberp test) (compile-form consequent target representation)) ((equal (derive-compiler-type test) +true-type+) - (compile-forms-and-maybe-emit-clear-values test nil nil) + (compile-forms-and-maybe-emit-clear-values test nil nil) (compile-form consequent target representation)) ((and (consp test) (eq (car test) 'OR)) (p2-if-or form target representation)) @@ -2907,7 +2904,7 @@ (defun restore-environment-and-make-handler (register label-START) (let ((label-END (gensym)) - (label-EXIT (gensym))) + (label-EXIT (gensym))) (emit 'goto label-EXIT) (label label-END) (restore-dynamic-environment register) @@ -2944,7 +2941,7 @@ ;; Bind the variables. (aver (= (length vars) (length variables))) (cond ((= (length vars) 1) - (compile-forms-and-maybe-emit-clear-values (third form) 'stack nil) + (compile-forms-and-maybe-emit-clear-values (third form) 'stack nil) (compile-binding (car variables))) (t (let* ((*register* *register*) @@ -3480,7 +3477,7 @@ (when (and (tagbody-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 (environment-register-to-restore tag-block))) + (restore-dynamic-environment (environment-register-to-restore tag-block))) (maybe-generate-interrupt-check) (emit 'goto (tag-label tag)) (return-from p2-go)) @@ -3524,9 +3521,9 @@ (return-from p2-instanceof-predicate)) (let ((arg (%cadr form))) (cond ((null target) - (compile-forms-and-maybe-emit-clear-values arg nil nil)) + (compile-forms-and-maybe-emit-clear-values arg nil nil)) (t - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-instanceof java-class) (convert-representation :boolean representation) (emit-move-from-stack target representation))))) @@ -3677,7 +3674,7 @@ (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil) (emit-invoke-method "cadr" target representation)) (t - (emit-car/cdr arg target representation "car"))))) + (emit-car/cdr arg target representation "car"))))) (define-inlined-function p2-cdr (form target representation) ((check-arg-count form 1)) @@ -3692,7 +3689,7 @@ (arg1 (%car args)) (arg2 (%cadr args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil)) + arg2 'stack nil)) (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)) (emit-move-from-stack target)) @@ -3842,12 +3839,12 @@ (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) (dformat t "(compiland-closure-register parent) = ~S~%" - (compiland-closure-register parent)) + (compiland-closure-register parent)) (emit-checkcast +lisp-compiled-closure+) (duplicate-closure-array parent) (emit-invokestatic +lisp+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+))) + (list +lisp-object+ +closure-binding-array+) + +lisp-object+))) (emit-move-to-variable (local-function-variable local-function))) (defknown p2-labels-process-compiland (t) t) @@ -4002,7 +3999,7 @@ (emit-getstatic *this-class* g +lisp-object+))))) ; Stack: template-function ((and (member name *functions-defined-in-current-file* :test #'equal) - (not (notinline-p name))) + (not (notinline-p name))) (emit-getstatic *this-class* (declare-setf-function name) +lisp-object+) (emit-move-from-stack target)) @@ -4083,8 +4080,8 @@ (emit-move-from-stack target representation)) ((and (fixnum-type-p type1) low2 high2 (<= -31 low2 high2 0)) ; Negative shift. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) (emit 'ineg) (emit 'ishr) (convert-representation :int representation) @@ -4093,21 +4090,21 @@ (cond ((and low2 high2 (<= 0 low2 high2 63) ; Non-negative shift. (java-long-type-p type1) (java-long-type-p result-type)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :int) (emit 'lshl) (convert-representation :long representation)) ((and low2 high2 (<= -63 low2 high2 0) ; Negative shift. (java-long-type-p type1) (java-long-type-p result-type)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :int) (emit 'ineg) (emit 'lshr) (convert-representation :long representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "ash" '(:int) +lisp-object+) (fix-boxing representation result-type))) (emit-move-from-stack target representation)) @@ -4127,18 +4124,18 @@ (cond ((and (integerp arg1) (integerp arg2)) (compile-constant (logand arg1 arg2) target representation)) ((and (integer-type-p type1) (eql arg2 0)) - (compile-forms-and-maybe-emit-clear-values arg1 nil nil) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil) (compile-constant 0 target representation)) ((eql (fixnum-constant-value type1) -1) - (compile-forms-and-maybe-emit-clear-values arg1 nil nil - arg2 target representation)) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil + arg2 target representation)) ((eql (fixnum-constant-value type2) -1) - (compile-forms-and-maybe-emit-clear-values arg1 target representation - arg2 nil nil)) + (compile-forms-and-maybe-emit-clear-values arg1 target representation + arg2 nil nil)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) ;; Both arguments are fixnums. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) (emit 'iand) (convert-representation :int representation) (emit-move-from-stack target representation)) @@ -4147,15 +4144,15 @@ (and (fixnum-type-p type2) (compiler-subtypep type2 'unsigned-byte))) ;; One of the arguments is a positive fixnum. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) (emit 'iand) (convert-representation :int representation) (emit-move-from-stack target representation)) ((and (java-long-type-p type1) (java-long-type-p type2)) ;; Both arguments are longs. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) (emit 'land) (convert-representation :long representation) (emit-move-from-stack target representation)) @@ -4164,29 +4161,29 @@ (and (java-long-type-p type2) (compiler-subtypep type2 'unsigned-byte))) ;; One of the arguments is a positive long. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) (emit 'land) (convert-representation :long representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) ((fixnum-type-p type1) ;; arg1 is a fixnum, but arg2 is not - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) ;; swap args (emit 'swap) (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (emit-invokevirtual +lisp-object+ "LOGAND" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) @@ -4202,7 +4199,7 @@ (compile-constant 0 target representation)) (1 (let ((arg (%car args))) - (compile-forms-and-maybe-emit-clear-values arg target representation))) + (compile-forms-and-maybe-emit-clear-values arg target representation))) (2 (let* ((arg1 (%car args)) (arg2 (%cadr args)) @@ -4217,48 +4214,48 @@ type2 (derive-compiler-type arg2) result-type (derive-compiler-type form)) (cond ((and (fixnum-constant-value type1) (fixnum-constant-value type2)) - (compile-forms-and-maybe-emit-clear-values arg1 nil nil - arg2 nil nil) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil + arg2 nil nil) (compile-constant (logior (fixnum-constant-value type1) (fixnum-constant-value type2)) target representation)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) (emit 'ior) (convert-representation :int representation) (emit-move-from-stack target representation)) ((and (eql (fixnum-constant-value type1) 0) (< *safety* 3)) - (compile-forms-and-maybe-emit-clear-values arg1 nil nil - arg2 target representation)) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil + arg2 target representation)) ((and (eql (fixnum-constant-value type2) 0) (< *safety* 3)) - (compile-forms-and-maybe-emit-clear-values arg1 target representation - arg2 nil nil)) + (compile-forms-and-maybe-emit-clear-values arg1 target representation + arg2 nil nil)) ((or (eq representation :long) (and (java-long-type-p type1) (java-long-type-p type2))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) (emit 'lor) (convert-representation :long representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) ((fixnum-type-p type1) ;; arg1 is of fixnum type, but arg2 is not - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) ;; swap args (emit 'swap) (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (emit-invokevirtual +lisp-object+ "LOGIOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) @@ -4277,7 +4274,7 @@ (compile-constant 0 target representation)) (1 (let ((arg (%car args))) - (compile-forms-and-maybe-emit-clear-values arg target representation))) + (compile-forms-and-maybe-emit-clear-values arg target representation))) (2 (let* ((arg1 (%car args)) (arg2 (%cadr args)) @@ -4292,27 +4289,27 @@ type2 (derive-compiler-type arg2) result-type (derive-compiler-type form)) (cond ((eq representation :int) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) (emit 'ixor)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) (emit 'ixor) (convert-representation :int representation)) ((and (java-long-type-p type1) (java-long-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) (emit 'lxor) (convert-representation :long representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+) (fix-boxing representation result-type)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (emit-invokevirtual +lisp-object+ "LOGXOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type))) @@ -4327,14 +4324,14 @@ ((check-arg-count form 1)) (cond ((and (fixnum-type-p (derive-compiler-type form))) (let ((arg (%cadr form))) - (compile-forms-and-maybe-emit-clear-values arg 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg 'stack :int) (emit 'iconst_m1) (emit 'ixor) (convert-representation :int representation) (emit-move-from-stack target representation))) (t (let ((arg (%cadr form))) - (compile-forms-and-maybe-emit-clear-values arg 'stack nil)) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil)) (emit-invokevirtual +lisp-object+ "LOGNOT" nil +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)))) @@ -4355,15 +4352,15 @@ ;; FIXME Add LispObject.ldb(), returning a Java int, for the case where we ;; need an unboxed fixnum result. (cond ((eql size 0) - (compile-forms-and-maybe-emit-clear-values size-arg nil nil - position-arg nil nil - arg3 nil nil) + (compile-forms-and-maybe-emit-clear-values size-arg nil nil + position-arg nil nil + arg3 nil nil) (compile-constant 0 target representation)) ((and size position) (cond ((<= (+ position size) 31) - (compile-forms-and-maybe-emit-clear-values size-arg nil nil - position-arg nil nil - arg3 'stack :int) + (compile-forms-and-maybe-emit-clear-values size-arg nil nil + position-arg nil nil + arg3 'stack :int) (unless (zerop position) (emit-push-constant-int position) (emit 'ishr)) @@ -4372,9 +4369,9 @@ (convert-representation :int representation) (emit-move-from-stack target representation)) ((<= (+ position size) 63) - (compile-forms-and-maybe-emit-clear-values size-arg nil nil - position-arg nil nil - arg3 'stack :long) + (compile-forms-and-maybe-emit-clear-values size-arg nil nil + position-arg nil nil + arg3 'stack :long) (unless (zerop position) (emit-push-constant-int position) (emit 'lshr)) @@ -4389,7 +4386,7 @@ (convert-representation :long representation))) (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg3 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg3 'stack nil) (emit-push-constant-int size) (emit-push-constant-int position) (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+) @@ -4397,9 +4394,9 @@ (emit-move-from-stack target representation)))) ((and (fixnum-type-p size-type) (fixnum-type-p position-type)) - (compile-forms-and-maybe-emit-clear-values size-arg 'stack :int - position-arg 'stack :int - arg3 'stack nil) + (compile-forms-and-maybe-emit-clear-values size-arg 'stack :int + position-arg 'stack :int + arg3 'stack nil) (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved (emit 'pop) (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+) @@ -4419,19 +4416,19 @@ (cond ((and (eq representation :int) (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) (emit-invokestatic +lisp+ "mod" '(:int :int) :int) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) (emit-invokevirtual +lisp-object+ "MOD" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type @@ -4444,7 +4441,7 @@ (let* ((arg (cadr form)) (type (derive-compiler-type arg))) (cond ((fixnum-type-p type) - (compile-forms-and-maybe-emit-clear-values arg 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg 'stack :int) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) (emit 'ifne LABEL1) @@ -4463,7 +4460,7 @@ (label LABEL2) (emit-move-from-stack target representation))) ((java-long-type-p type) - (compile-forms-and-maybe-emit-clear-values arg 'stack :long) + (compile-forms-and-maybe-emit-clear-values arg 'stack :long) (emit 'lconst_0) (emit 'lcmp) (let ((LABEL1 (gensym)) @@ -4476,7 +4473,7 @@ (label LABEL2) (emit-move-from-stack target representation))) (t - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-invoke-method "ZEROP" target representation))))) ;; find-class symbol &optional errorp environment => class @@ -4506,8 +4503,8 @@ (emit-move-from-stack target representation)) (2 (let ((arg2 (second args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :boolean) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :boolean) (emit-invokestatic +lisp-class+ "findClass" (list +lisp-object+ :boolean) +lisp-object+) (fix-boxing representation nil) @@ -4524,7 +4521,7 @@ (case arg-count (2 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + arg2 'stack nil) (emit 'swap) (cond (target (emit-invokevirtual +lisp-object+ "VECTOR_PUSH_EXTEND" @@ -4544,7 +4541,7 @@ (arg1 (first args)) (arg2 (second args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + arg2 'stack nil) (emit-invokevirtual +lisp-object+ "SLOT_VALUE" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) @@ -4561,8 +4558,8 @@ (*register* *register*) (value-register (when target (allocate-register)))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil - arg3 'stack nil) + arg2 'stack nil + arg3 'stack nil) (when value-register (emit 'dup) (astore value-register)) @@ -4578,7 +4575,7 @@ ((check-arg-count form 1)) (let ((arg (%cadr form))) (cond ((eq (derive-compiler-type arg) 'STREAM) - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-checkcast +lisp-stream+) (emit-invokevirtual +lisp-stream+ "getElementType" nil +lisp-object+) @@ -4625,7 +4622,7 @@ (let* ((arg1 (%car args)) (type1 (derive-compiler-type arg1))) (cond ((compiler-subtypep type1 'stream) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-checkcast +lisp-stream+) (emit-push-constant-int 1) (emit-push-nil) @@ -4639,7 +4636,7 @@ (type1 (derive-compiler-type arg1)) (arg2 (%cadr args))) (cond ((and (compiler-subtypep type1 'stream) (null arg2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-checkcast +lisp-stream+) (emit-push-constant-int 0) (emit-push-nil) @@ -4933,9 +4930,9 @@ (defun derive-compiler-types (args op) (flet ((combine (x y) - (derive-type-numeric-op op x y))) + (derive-type-numeric-op op x y))) (reduce #'combine (cdr args) :key #'derive-compiler-type - :initial-value (derive-compiler-type (car args))))) + :initial-value (derive-compiler-type (car args))))) (defknown derive-type-minus (t) t) (defun derive-type-minus (form) @@ -5225,37 +5222,35 @@ (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))) + (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+) - (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+ (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+ (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))))) - - + (dolist (cons-head cons-heads) + (emit-new +lisp-cons+) + (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+ (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+ (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) (cons-for-list/list* form target representation)) @@ -5268,7 +5263,7 @@ (let ((index-form (second form)) (list-form (third form))) (compile-forms-and-maybe-emit-clear-values index-form 'stack :int - list-form 'stack nil) + list-form 'stack nil) (emit 'swap) (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type @@ -5305,9 +5300,9 @@ (t (sys::format t "p2-times: unsupported rep case")))) (convert-representation result-rep representation) - (emit-move-from-stack target representation)) + (emit-move-from-stack target representation)) ((fixnump arg2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-int arg2) (emit-invokevirtual +lisp-object+ "multiplyBy" '(:int) +lisp-object+) (fix-boxing representation result-type) @@ -5392,12 +5387,12 @@ (cond ((and (numberp arg1) (numberp arg2)) (compile-constant (+ arg1 arg2) target representation)) ((and (numberp arg1) (eql arg1 0)) - (compile-forms-and-maybe-emit-clear-values arg1 nil nil - arg2 'stack representation) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil + arg2 'stack representation) (emit-move-from-stack target representation)) ((and (numberp arg2) (eql arg2 0)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack representation - arg2 nil nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack representation + arg2 nil nil) (emit-move-from-stack target representation)) (result-rep (compile-forms-and-maybe-emit-clear-values @@ -5416,13 +5411,13 @@ (convert-representation result-rep representation) (emit-move-from-stack target representation)) ((eql arg2 1) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-invoke-method "incr" target representation)) ((eql arg1 1) - (compile-forms-and-maybe-emit-clear-values arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg2 'stack nil) (emit-invoke-method "incr" target representation)) ((or (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values + (compile-forms-and-maybe-emit-clear-values arg1 'stack (when (fixnum-type-p type1) :int) arg2 'stack (when (null (fixnum-type-p type1)) :int)) (when (fixnum-type-p type1) @@ -5465,7 +5460,7 @@ (convert-representation type-rep representation) (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-invokevirtual +lisp-object+ "negate" nil +lisp-object+) (fix-boxing representation nil) @@ -5480,7 +5475,7 @@ (cond ((and (numberp arg1) (numberp arg2)) (compile-constant (- arg1 arg2) target representation)) (result-rep - (compile-forms-and-maybe-emit-clear-values + (compile-forms-and-maybe-emit-clear-values arg1 'stack result-rep arg2 'stack result-rep) (emit (case result-rep @@ -5495,7 +5490,7 @@ (convert-representation result-rep representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) (emit-invokevirtual +lisp-object+ @@ -5540,8 +5535,8 @@ '(:int) :char) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ (symbol-name op) ;; "CHAR" or "SCHAR" '(:int) +lisp-object+) @@ -5595,8 +5590,8 @@ (neq representation :char)) ; FIXME (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -5667,12 +5662,12 @@ (type1 (derive-compiler-type arg1))) (ecase representation (:int - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "aref" '(:int) :int)) (:long - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long)) (:char (cond ((compiler-subtypep type1 'string) @@ -5683,15 +5678,15 @@ (emit-invokevirtual +lisp-abstract-string+ "charAt" '(:int) :char)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) (emit-unbox-character)))) ((nil :float :double :boolean) ;;###FIXME for float and double, we probably want ;; separate java methods to retrieve the values. - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) (convert-representation nil representation))) (emit-move-from-stack target representation))) @@ -5747,7 +5742,7 @@ (arg2 (second args))) (cond ((and (fixnump arg2) (null representation)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (case arg2 (0 (emit-invokevirtual +lisp-object+ "getSlotValue_0" @@ -5767,7 +5762,7 @@ '(:int) +lisp-object+))) (emit-move-from-stack target representation)) ((fixnump arg2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-constant-int arg2) (ecase representation (:int @@ -5796,8 +5791,8 @@ (<= 0 arg2 3)) (let* ((*register* *register*) (value-register (when target (allocate-register)))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg3 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg3 'stack nil) (when value-register (emit 'dup) (astore value-register)) @@ -5838,7 +5833,7 @@ (emit-push-false representation)) ((and (consp arg) (memq (%car arg) '(NOT NULL))) - (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil) + (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil) (emit-push-nil) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) @@ -5849,11 +5844,11 @@ (emit-push-false representation) (label LABEL2))) ((eq representation :boolean) - (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) (emit 'iconst_1) (emit 'ixor)) ((eq (derive-compiler-type arg) 'BOOLEAN) - (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) (emit 'ifeq LABEL1) @@ -5863,7 +5858,7 @@ (emit-push-t) (label LABEL2))) (t - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) (emit-push-nil) @@ -5881,8 +5876,8 @@ (arg1 (%car args)) (arg2 (%cadr args))) (cond ((fixnum-type-p (derive-compiler-type arg1)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) (emit 'swap) (emit-invokevirtual +lisp-object+ "nthcdr" '(:int) +lisp-object+) (fix-boxing representation nil) @@ -5904,11 +5899,11 @@ (arg2 (%cadr args)) (FAIL (gensym)) (DONE (gensym))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :boolean) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :boolean) (emit 'ifeq FAIL) (ecase representation (:boolean - (compile-forms-and-maybe-emit-clear-values arg2 'stack :boolean) + (compile-forms-and-maybe-emit-clear-values arg2 'stack :boolean) (emit 'goto DONE) (label FAIL) (emit 'iconst_0)) @@ -5938,7 +5933,7 @@ (arg2 (%cadr args)) (LABEL1 (gensym)) (LABEL2 (gensym))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit 'dup) (emit-push-nil) (emit 'if_acmpne LABEL1) @@ -5964,7 +5959,7 @@ (emit-move-from-stack target)) (1 (let ((arg (%car args))) - (compile-forms-and-maybe-emit-clear-values arg target representation))) + (compile-forms-and-maybe-emit-clear-values arg target representation))) (2 (emit-push-current-thread) (let ((arg1 (%car args)) @@ -6113,13 +6108,13 @@ (eq (variable-name (var-ref-variable (third value-form))) name)) (emit-push-current-thread) (emit-load-externalized-object name) - (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) + (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) (emit-invokevirtual +lisp-thread+ "pushSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-object+)) (t (emit-push-current-thread) (emit-load-externalized-object name) - (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) + (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) (emit-invokevirtual +lisp-thread+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+))) (fix-boxing representation nil) @@ -6129,7 +6124,7 @@ (when (zerop (variable-reads variable)) ;; If we never read the variable, we don't have to set it. (cond (target - (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) + (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t @@ -6198,7 +6193,7 @@ (defun p2-sxhash (form target representation) (cond ((check-arg-count form 1) (let ((arg (%cadr form))) - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-invokevirtual +lisp-object+ "sxhash" nil :int) (convert-representation :int representation) (emit-move-from-stack target representation))) @@ -6210,7 +6205,7 @@ ((check-arg-count form 1)) (let ((arg (%cadr form))) (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-checkcast +lisp-symbol+) (emit-getfield +lisp-symbol+ "name" +lisp-simple-string+) (emit-move-from-stack target representation)) @@ -6222,7 +6217,7 @@ ((check-arg-count form 1)) (let ((arg (%cadr form))) (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-checkcast +lisp-symbol+) (emit-invokevirtual +lisp-symbol+ "getPackage" nil +lisp-object+) @@ -6236,7 +6231,7 @@ (when (check-arg-count form 1) (let ((arg (%cadr form))) (when (eq (derive-compiler-type arg) 'SYMBOL) - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-checkcast +lisp-symbol+) (emit-push-current-thread) (emit-invokevirtual +lisp-symbol+ "symbolValue" @@ -6257,7 +6252,7 @@ (CONS +lisp-cons+) (HASH-TABLE +lisp-hash-table+) (FIXNUM +lisp-fixnum+) - (STREAM +lisp-stream+) + (STREAM +lisp-stream+) (STRING +lisp-abstract-string+) (VECTOR +lisp-abstract-vector+))) (expected-type-java-symbol-name (case expected-type @@ -6313,7 +6308,7 @@ (compile-form arg 'stack :char) ;; we change the representation between the above and here ;; ON PURPOSE! - (convert-representation :int representation) + (convert-representation :int representation) (emit-move-from-stack target representation)) (t (compile-function-call form target representation))))) @@ -6321,7 +6316,7 @@ (defknown p2-java-jclass (t t t) t) (define-inlined-function p2-java-jclass (form target representation) ((and (= 2 (length form)) - (stringp (cadr form)))) + (stringp (cadr form)))) (let ((c (ignore-errors (java:jclass (cadr form))))) (if c (compile-constant c target representation) ;; delay resolving the method to run-time; it's unavailable now @@ -6330,7 +6325,7 @@ (defknown p2-java-jconstructor (t t t) t) (define-inlined-function p2-java-jconstructor (form target representation) ((and (< 1 (length form)) - (every #'stringp (cdr form)))) + (every #'stringp (cdr form)))) (let ((c (ignore-errors (apply #'java:jconstructor (cdr form))))) (if c (compile-constant c target representation) ;; delay resolving the method to run-time; it's unavailable now @@ -6339,7 +6334,7 @@ (defknown p2-java-jmethod (t t t) t) (define-inlined-function p2-java-jmethod (form target representation) ((and (< 1 (length form)) - (every #'stringp (cdr form)))) + (every #'stringp (cdr form)))) (let ((m (ignore-errors (apply #'java:jmethod (cdr form))))) (if m (compile-constant m target representation) ;; delay resolving the method to run-time; it's unavailable now @@ -6348,27 +6343,27 @@ #|(defknown p2-java-jcall (t t t) t) (define-inlined-function p2-java-jcall (form target representation) ((and (> *speed* *safety*) - (< 1 (length form)) - (eq 'jmethod (car (cadr form))) - (every #'stringp (cdr (cadr form))))) + (< 1 (length form)) + (eq 'jmethod (car (cadr form))) + (every #'stringp (cdr (cadr form))))) (let ((m (ignore-errors (eval (cadr form))))) - (if m - (let ((must-clear-values nil) - (arg-types (raw-arg-types (jmethod-params m)))) - (declare (type boolean must-clear-values)) - (dolist (arg (cddr form)) - (compile-form arg 'stack nil) - (unless must-clear-values - (unless (single-valued-p arg) - (setf must-clear-values t)))) - (when must-clear-values - (emit-clear-values)) - (dotimes (i (jarray-length raw-arg-types)) - (push (jarray-ref raw-arg-types i) arg-types)) - (emit-invokevirtual (jclass-name (jmethod-declaring-class m)) - (jmethod-name m) - (nreverse arg-types) - (jmethod-return-type m))) + (if m + (let ((must-clear-values nil) + (arg-types (raw-arg-types (jmethod-params m)))) + (declare (type boolean must-clear-values)) + (dolist (arg (cddr form)) + (compile-form arg 'stack nil) + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t)))) + (when must-clear-values + (emit-clear-values)) + (dotimes (i (jarray-length raw-arg-types)) + (push (jarray-ref raw-arg-types i) arg-types)) + (emit-invokevirtual (jclass-name (jmethod-declaring-class m)) + (jmethod-name m) + (nreverse arg-types) + (jmethod-return-type m))) ;; delay resolving the method to run-time; it's unavailable now (compile-function-call form target representation))))|# @@ -6394,13 +6389,13 @@ (return-from p2-char=)) (cond ((characterp arg1) (emit-push-constant-int (char-code arg1)) - (compile-forms-and-maybe-emit-clear-values arg2 'stack :char)) + (compile-forms-and-maybe-emit-clear-values arg2 'stack :char)) ((characterp arg2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char) (emit-push-constant-int (char-code arg2))) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack :char))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char + arg2 'stack :char))) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) (emit 'if_icmpeq LABEL1) @@ -6768,11 +6763,6 @@ (arg-types (analyze-args compiland)) (method (make-method "execute" +lisp-object+ arg-types :flags '(:final :public))) - (code (method-add-code method)) - (*current-code-attribute* code) - (*code* ()) - (*register* 1) ;; register 0: "this" pointer - (*registers-allocated* 1) (*visible-variables* *visible-variables*) (*thread* nil) @@ -6780,205 +6770,214 @@ (label-START (gensym))) (class-add-method class-file method) - (when (fixnump *source-line-number*) - (let ((table (make-line-numbers-attribute))) - (method-add-attribute method table) - (line-numbers-add-line table 0 *source-line-number*))) - - (dolist (var (compiland-arg-vars compiland)) - (push var *visible-variables*)) - (dolist (var (compiland-free-specials compiland)) - (push var *visible-variables*)) - - (when *using-arg-array* - (setf (compiland-argument-register compiland) (allocate-register))) - - ;; 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))) - (if *using-arg-array* - (setf (variable-index variable) index) - (setf (variable-register variable) (allocate-register))) - (incf index))) - - ;; Reserve the next available slot for the thread register. - (setf *thread* (allocate-register)) - - (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* - (if (not *child-p*) - (progn - ;; if we're the ultimate parent: create the closure array - (emit-push-constant-int (length *closure-variables*)) - (emit-anewarray +lisp-closure-binding+)) - (progn - (aload 0) - (emit-getfield +lisp-compiled-closure+ "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 - (and *closure-variables* (not *child-p*))) - (dformat t "~S moving arguments to closure array~%" - (compiland-name compiland)) - (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 +lisp-closure-binding+) - (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)))) - (aload (variable-register variable)) - (setf (variable-register variable) nil)) - ((variable-index variable) - (aload (compiland-argument-register compiland)) - (emit-push-constant-int (variable-index variable)) - (emit 'aaload) - (setf (variable-index variable) nil)) - (t - (assert (not "Can't happen!!")))) - (emit-invokespecial-init +lisp-closure-binding+ - (list +lisp-object+)) - (emit 'aastore))))) - - (when *closure-variables* - (aver (not (null (compiland-closure-register compiland)))) - (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* - (dolist (variable (compiland-arg-vars compiland)) - (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)) - (emit 'aaload) - (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. - (dolist (variable (compiland-arg-vars compiland)) - (p2-compiland-unbox-variable variable)) - - ;; Establish dynamic bindings for any variables declared special. - (when (some #'variable-special-p (compiland-arg-vars compiland)) - ;; Save the dynamic environment - (setf (compiland-environment-register compiland) - (allocate-register)) - (save-dynamic-environment (compiland-environment-register compiland)) - (label label-START) - (dolist (variable (compiland-arg-vars compiland)) - (when (variable-special-p variable) - (setf (variable-binding-register variable) (allocate-register)) - (emit-push-current-thread) - (emit-push-variable-name variable) - (cond ((variable-register variable) + (setf (abcl-class-file-lambda-list class-file) args) + (setf (abcl-class-file-superclass class-file) + (if (or *hairy-arglist-p* + (and *child-p* *closure-variables*)) + +lisp-compiled-closure+ + +lisp-compiled-primitive+)) + + (let ((constructor (make-constructor class-file))) + (setf (abcl-class-file-constructor class-file) constructor) + (class-add-method class-file constructor)) + #+enable-when-generating-clinit + (let ((clinit (make-static-initializer class-file))) + (setf (abcl-class-file-static-initializer class-file) clinit) + (class-add-method class-file clinit)) + + (with-code-to-method (class-file method) + (setf *register* 1 ;; register 0: "this" pointer + *registers-allocated* 1) + + (when (fixnump *source-line-number*) + (let ((table (make-line-numbers-attribute))) + (method-add-attribute method table) + (line-numbers-add-line table 0 *source-line-number*))) + + (dolist (var (compiland-arg-vars compiland)) + (push var *visible-variables*)) + (dolist (var (compiland-free-specials compiland)) + (push var *visible-variables*)) + + (when *using-arg-array* + (setf (compiland-argument-register compiland) (allocate-register))) + + ;; 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))) + (if *using-arg-array* + (setf (variable-index variable) index) + (setf (variable-register variable) (allocate-register))) + (incf index))) + + ;; Reserve the next available slot for the thread register. + (setf *thread* (allocate-register)) + + (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* + (if (not *child-p*) + (progn + ;; if we're the ultimate parent: create the closure array + (emit-push-constant-int (length *closure-variables*)) + (emit-anewarray +lisp-closure-binding+)) + (progn + (aload 0) + (emit-getfield +lisp-compiled-closure+ "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 + (and *closure-variables* (not *child-p*))) + (dformat t "~S moving arguments to closure array~%" + (compiland-name compiland)) + (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 +lisp-closure-binding+) + (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)))) (aload (variable-register variable)) (setf (variable-register variable) nil)) ((variable-index variable) (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) (emit 'aaload) - (setf (variable-index variable) nil))) - (emit-invokevirtual +lisp-thread+ "bindSpecial" - (list +lisp-symbol+ +lisp-object+) - +lisp-special-binding+) - (astore (variable-binding-register variable))))) - - (compile-progn-body body 'stack) - - (when (compiland-environment-register compiland) - (restore-dynamic-environment (compiland-environment-register compiland))) - - (unless *code* - (emit-push-nil)) - (emit 'areturn) - - ;; Warn if any unused args. (Is this the right place?) - (check-for-unused-variables (compiland-arg-vars compiland)) - - ;; Go back and fill in prologue. - (let ((code *code*)) - (setf *code* ()) - (let ((arity (compiland-arity compiland))) - (when arity - (generate-arg-count-check arity))) - - (when *hairy-arglist-p* - (aload 0) ; this - (aver (not (null (compiland-argument-register compiland)))) - (aload (compiland-argument-register compiland)) ; arg vector - (cond ((or (memq '&OPTIONAL args) (memq '&KEY args)) - (ensure-thread-var-initialized) - (maybe-initialize-thread-var) - (emit-push-current-thread) - (emit-invokevirtual *this-class* "processArgs" - (list +lisp-object-array+ +lisp-thread+) - +lisp-object-array+)) - (t - (emit-invokevirtual *this-class* "fastProcessArgs" - (list +lisp-object-array+) - +lisp-object-array+))) - (astore (compiland-argument-register compiland))) - - (unless (and *hairy-arglist-p* - (or (memq '&OPTIONAL args) (memq '&KEY args))) - (maybe-initialize-thread-var)) - (setf *code* (nconc code *code*))) - - (setf (abcl-class-file-superclass class-file) - (if (or *hairy-arglist-p* - (and *child-p* *closure-variables*)) - +lisp-compiled-closure+ - +lisp-compiled-primitive+)) + (setf (variable-index variable) nil)) + (t + (assert (not "Can't happen!!")))) + (emit-invokespecial-init +lisp-closure-binding+ + (list +lisp-object+)) + (emit 'aastore))))) + + (when *closure-variables* + (aver (not (null (compiland-closure-register compiland)))) + (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* + (dolist (variable (compiland-arg-vars compiland)) + (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)) + (emit 'aaload) + (astore register) + (setf (variable-register variable) register) + (setf (variable-index variable) nil))))) - (setf (abcl-class-file-lambda-list class-file) args) - (setf (code-max-locals code) *registers-allocated*) - (setf (code-code code) *code*)) + (p2-compiland-process-type-declarations body) + (generate-type-checks-for-variables (compiland-arg-vars compiland)) + ;; Unbox variables. + (dolist (variable (compiland-arg-vars compiland)) + (p2-compiland-unbox-variable variable)) + ;; Establish dynamic bindings for any variables declared special. + (when (some #'variable-special-p (compiland-arg-vars compiland)) + ;; Save the dynamic environment + (setf (compiland-environment-register compiland) + (allocate-register)) + (save-dynamic-environment (compiland-environment-register compiland)) + (label label-START) + (dolist (variable (compiland-arg-vars compiland)) + (when (variable-special-p variable) + (setf (variable-binding-register variable) (allocate-register)) + (emit-push-current-thread) + (emit-push-variable-name variable) + (cond ((variable-register variable) + (aload (variable-register variable)) + (setf (variable-register variable) nil)) + ((variable-index variable) + (aload (compiland-argument-register compiland)) + (emit-push-constant-int (variable-index variable)) + (emit 'aaload) + (setf (variable-index variable) nil))) + (emit-invokevirtual +lisp-thread+ "bindSpecial" + (list +lisp-symbol+ +lisp-object+) + +lisp-special-binding+) + (astore (variable-binding-register variable))))) + + (compile-progn-body body 'stack) + + (when (compiland-environment-register compiland) + (restore-dynamic-environment (compiland-environment-register compiland))) + + (unless *code* + (emit-push-nil)) + (emit 'areturn) + + ;; Warn if any unused args. (Is this the right place?) + (check-for-unused-variables (compiland-arg-vars compiland)) + + ;; Go back and fill in prologue. + (let ((code *code*)) + (setf *code* ()) + (let ((arity (compiland-arity compiland))) + (when arity + (generate-arg-count-check arity))) + + (when *hairy-arglist-p* + (aload 0) ; this + (aver (not (null (compiland-argument-register compiland)))) + (aload (compiland-argument-register compiland)) ; arg vector + (cond ((or (memq '&OPTIONAL args) (memq '&KEY args)) + (ensure-thread-var-initialized) + (maybe-initialize-thread-var) + (emit-push-current-thread) + (emit-invokevirtual *this-class* "processArgs" + (list +lisp-object-array+ +lisp-thread+) + +lisp-object-array+)) + (t + (emit-invokevirtual *this-class* "fastProcessArgs" + (list +lisp-object-array+) + +lisp-object-array+))) + (astore (compiland-argument-register compiland))) + + (unless (and *hairy-arglist-p* + (or (memq '&OPTIONAL args) (memq '&KEY args))) + (maybe-initialize-thread-var)) + (setf *code* (nconc code *code*))) + )) t) (defun p2-with-inline-code (form target representation) ;;form = (with-inline-code (&optional target-var repr-var) ...body...) (destructuring-bind (&optional target-var repr-var) (cadr form) (eval `(let (,@(when target-var `((,target-var ,target))) - ,@(when repr-var `((,repr-var ,representation)))) - ,@(cddr form))))) + ,@(when repr-var `((,repr-var ,representation)))) + ,@(cddr form))))) (defun compile-1 (compiland stream) (let ((*all-variables* nil) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Nov 16 14:40:03 2010 @@ -1139,6 +1139,7 @@ to which it has been attached has been superseded.") (defvar *current-code-attribute* nil) +(defvar *method*) (defun save-code-specials (code) (setf (code-code code) *code* @@ -1158,6 +1159,7 @@ (when *current-code-attribute* (save-code-specials *current-code-attribute*)) (let* ((,m ,method) + (*method* ,m) (,c (method-ensure-code ,method)) (*pool* (class-file-constants ,class-file)) (*code* (code-code ,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 Tue Nov 16 14:40:03 2010 @@ -124,7 +124,8 @@ class-name lambda-name lambda-list ; as advertised - static-code + static-initializer + constructor objects ;; an alist of externalized objects and their field names (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions ) @@ -176,12 +177,10 @@ `(let* ((,var ,class-file) (*class-file* ,var) (*pool* (abcl-class-file-constants ,var)) - (*static-code* (abcl-class-file-static-code ,var)) (*externalized-objects* (abcl-class-file-objects ,var)) (*declared-functions* (abcl-class-file-functions ,var))) (progn , at body) - (setf (abcl-class-file-static-code ,var) *static-code* - (abcl-class-file-objects ,var) *externalized-objects* + (setf (abcl-class-file-objects ,var) *externalized-objects* (abcl-class-file-functions ,var) *declared-functions*)))) (defstruct compiland From mevenson at common-lisp.net Wed Nov 17 15:55:48 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 17 Nov 2010 10:55:48 -0500 Subject: [armedbear-cvs] r13026 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Wed Nov 17 10:55:47 2010 New Revision: 13026 Log: Further fix for #110 eliminating the use of the URLDecoder.decode(). Upon further review, the attempt to decode a URL path via the URL unescaping functions intended for escaping HTML Forms submission is just wrong, originating as far as I can tell in my initial Pathname commit. There may be issues where we should treat strings of the form 'file:URI' with real URI escaping rules to remove %bb byte-encoding, but these rules might well confuse those attempting to include '%' in files, so we leave that to more formal specification. Untabify Pathname.java. Tests for correct parsing of device under Windows. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/test/lisp/abcl/jar-pathname.lisp trunk/abcl/test/lisp/abcl/pathname-tests.lisp 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 Wed Nov 17 10:55:47 2010 @@ -196,28 +196,18 @@ public Pathname(URL url) { if ("file".equals(url.getProtocol())) { - String s; - try { - s = URLDecoder.decode(url.getPath(), "UTF-8"); - // But rencode \SPACE as '+' - s = s.replace(' ', '+'); - } catch (java.io.UnsupportedEncodingException uee) { - // Can't happen: every Java is supposed to support - // at least UTF-8 encoding - Debug.assertTrue(false); - s = null; - } + String s = url.getPath(); if (s != null) { - if (Utilities.isPlatformWindows) { - // Workaround for Java's idea of URLs - // new (URL"file:///c:/a/b").getPath() --> "/c:/a/b" + if (Utilities.isPlatformWindows) { + // Workaround for Java's idea of URLs + // new (URL"file:///c:/a/b").getPath() --> "/c:/a/b" // whereas we need "c" to be the DEVICE. - if (s.length() > 2 - && s.charAt(0) == '/' - && s.charAt(2) == ':') { - s = s.substring(1); - } - } + if (s.length() > 2 + && s.charAt(0) == '/' + && s.charAt(2) == ':') { + s = s.substring(1); + } + } init(s); return; } @@ -653,13 +643,13 @@ sb.append('.'); if (type instanceof AbstractString) { String t = type.getStringValue(); - // Allow Windows shortcuts to include TYPE - if (!(t.endsWith(".lnk") && Utilities.isPlatformWindows)) { - if (t.indexOf('.') >= 0) { - Debug.assertTrue(namestring == null); - return null; - } - } + // Allow Windows shortcuts to include TYPE + if (!(t.endsWith(".lnk") && Utilities.isPlatformWindows)) { + if (t.indexOf('.') >= 0) { + Debug.assertTrue(namestring == null); + return null; + } + } sb.append(t); } else if (type == Keyword.WILD) { sb.append('*'); @@ -2106,12 +2096,12 @@ result = Utilities.getEntryAsInputStream(zipInputStream, entryPath); } else { ZipEntry entry = jarFile.getEntry(entryPath); - if (entry == null) { - Debug.trace("Failed to get InputStream for " - + "'" + getNamestring() + "'"); + if (entry == null) { + Debug.trace("Failed to get InputStream for " + + "'" + getNamestring() + "'"); // XXX should this be fatal? - Debug.assertTrue(false); - } + Debug.assertTrue(false); + } try { result = jarFile.getInputStream(entry); } catch (IOException e) { @@ -2280,7 +2270,7 @@ final File destination = new File(newNamestring); if (Utilities.isPlatformWindows) { if (destination.isFile()) { - ZipCache.remove(destination); + ZipCache.remove(destination); destination.delete(); } } @@ -2340,19 +2330,19 @@ } public URL toURL() throws MalformedURLException { - if(isURL()) { - return new URL(getNamestring()); - } else { - return toFile().toURL(); - } + if(isURL()) { + return new URL(getNamestring()); + } else { + return toFile().toURL(); + } } public File toFile() { - if(!isURL()) { - return new File(getNamestring()); - } else { - throw new RuntimeException(this + " does not represent a file"); - } + if(!isURL()) { + return new File(getNamestring()); + } else { + throw new RuntimeException(this + " does not represent a file"); + } } static { Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Wed Nov 17 10:55:47 2010 @@ -341,6 +341,19 @@ (:relative "a" "b") "foo" "jar" (:absolute "c" "d") "foo" "lisp") +(deftest jar-pathname.10 + (let ((s "jar:file:/foo/bar/a space/that!/this")) + (equal s + (namestring (pathname s)))) + t) + +(deftest jar-pathname.11 + (let ((s "jar:file:/foo/bar/a+space/that!/this")) + (equal s + (namestring (pathname s)))) + t) + + (deftest jar-pathname.match-p.1 (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd" "jar:file:/**/*.jar!/**/*.asd") Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/pathname-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/pathname-tests.lisp Wed Nov 17 10:55:47 2010 @@ -438,6 +438,21 @@ (equal #p"c:\\foo.bar" #p"C:\\FOO.BAR") t) +#+windows +(deftest pathname.windows.6 + (equal (pathname-device #p"z:/foo/bar") "z") + t) + +#+windows +(deftest pathname.windows.7 + (equal (pathname-device #p"file:z:/foo/bar") "z") + t) + +#+windows +(deftest pathname.windows.8 + (equal (pathname-device #p"zoo:/foo/bar") nil) + t) + (deftest wild.1 (check-physical-pathname #p"foo.*" nil "foo" :wild) t) From mevenson at common-lisp.net Fri Nov 19 11:24:13 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 19 Nov 2010 06:24:13 -0500 Subject: [armedbear-cvs] r13027 - trunk/abcl/contrib/asdf-install Message-ID: Author: mevenson Date: Fri Nov 19 06:24:10 2010 New Revision: 13027 Log: Fix ASDF-INSTALL fails to download (ticket #110). Use an 8-bit encoding (:iso-8559-1) in the streams for the package download to prevent attempts to recode if ABCL is running under a multi-bit encoding locale (i.e. UTF-8). Ensure that we use 'gtar' under Solaris. Modified: trunk/abcl/contrib/asdf-install/installer.lisp trunk/abcl/contrib/asdf-install/port.lisp trunk/abcl/contrib/asdf-install/variables.lisp Modified: trunk/abcl/contrib/asdf-install/installer.lisp ============================================================================== --- trunk/abcl/contrib/asdf-install/installer.lisp (original) +++ trunk/abcl/contrib/asdf-install/installer.lisp Fri Nov 19 06:24:10 2010 @@ -302,7 +302,7 @@ (defun tar-arguments (source packagename) #-(or :win32 :mswindows :scl) - (list "-C" (namestring (truename source)) + (list "-C" (namestring (truename source)) "-xzvf" (namestring (truename packagename))) #+(or :win32 :mswindows) (list "-l" @@ -311,7 +311,7 @@ (namestring (truename source)) (namestring (truename packagename)))) #+scl - (list "-C" (ext:unix-namestring (truename source)) + (list "-C" (ext:unix-namestring (truename source)) "-xzvf" (ext:unix-namestring (truename packagename)))) (defun extract-using-tar (to-dir tarball) @@ -333,7 +333,7 @@ (let* ((tar (extract source packagename)) ;; Some tar programs (OSX) list entries with preceeding "x " ;; as in "x entry/file.asd" - (pos-begin (if (= (search "x " tar) 0) + (pos-begin (if (string= (subseq tar 0 2) "x ") 2 0)) (pos-slash (or (position #\/ tar) @@ -344,7 +344,6 @@ (make-pathname :directory `(:relative ,(subseq tar pos-begin pos-slash))) source))) - ;(princ tar) (loop for sysfile in (append (directory (make-pathname :defaults *default-pathname-defaults* Modified: trunk/abcl/contrib/asdf-install/port.lisp ============================================================================== --- trunk/abcl/contrib/asdf-install/port.lisp (original) +++ trunk/abcl/contrib/asdf-install/port.lisp Fri Nov 19 06:24:10 2010 @@ -144,7 +144,7 @@ #+:abcl (let ((socket (ext:make-socket (url-host url) (url-port url)))) - (ext:get-socket-stream socket))) + (ext:get-socket-stream socket :external-format :iso-8859-1))) #+:sbcl @@ -322,6 +322,8 @@ '(:external-format :latin1) #+:scl '(:external-format :iso-8859-1) + #+abcl + '(:external-format :iso-8859-1) #+(or :clisp :digitool (and :lispworks :win32)) '(:element-type (unsigned-byte 8)))) Modified: trunk/abcl/contrib/asdf-install/variables.lisp ============================================================================== --- trunk/abcl/contrib/asdf-install/variables.lisp (original) +++ trunk/abcl/contrib/asdf-install/variables.lisp Fri Nov 19 06:24:10 2010 @@ -52,8 +52,8 @@ "A list of places to look for shell commands.") (defvar *gnu-tar-program* - #-(or :netbsd :freebsd :solaris) "tar" - #+(or :netbsd :freebsd :solaris) "gtar" + #-(or :netbsd :freebsd :solaris :sunos) "tar" + #+(or :netbsd :freebsd :solaris :sunos) "gtar" "Path to the GNU tar program") (eval-when (:compile-toplevel :load-toplevel :execute) From mevenson at common-lisp.net Fri Nov 19 11:30:37 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 19 Nov 2010 06:30:37 -0500 Subject: [armedbear-cvs] r13028 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Nov 19 06:30:34 2010 New Revision: 13028 Log: Add :SOLARIS to *FEATURES* Now both :SUNOS and :SOLARIS occur in *FEATURES*, as some ASDF packages seem to be looking for :SOLARIS and there is no known port of Java-1.5 to sunos-4, this should not harm anything. Modified: trunk/abcl/src/org/armedbear/lisp/Keyword.java trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Keyword.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Keyword.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Keyword.java Fri Nov 19 06:30:34 2010 @@ -126,6 +126,7 @@ RENAME = internKeyword("RENAME"), RENAME_AND_DELETE = internKeyword("RENAME-AND-DELETE"), SIZE = internKeyword("SIZE"), + SOLARIS = internKeyword("SOLARIS"), START = internKeyword("START"), STATUS = internKeyword("STATUS"), STREAM = internKeyword("STREAM"), 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 Nov 19 06:30:34 2010 @@ -2258,6 +2258,7 @@ Keyword.ANSI_CL, Keyword.UNIX, Keyword.SUNOS, + Keyword.SOLARIS, Keyword.CDR6)); } else if (osName.startsWith("Mac OS X") || From mevenson at common-lisp.net Fri Nov 19 18:16:12 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 19 Nov 2010 13:16:12 -0500 Subject: [armedbear-cvs] r13029 - trunk/abcl Message-ID: Author: mevenson Date: Fri Nov 19 13:16:09 2010 New Revision: 13029 Log: Ensure that build process exits with error if abcl.contrib.compile fails. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Fri Nov 19 13:16:09 2010 @@ -379,15 +379,17 @@ - + + + + From mevenson at common-lisp.net Fri Nov 19 18:21:12 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 19 Nov 2010 13:21:12 -0500 Subject: [armedbear-cvs] r13030 - trunk/abcl/contrib/asdf-install Message-ID: Author: mevenson Date: Fri Nov 19 13:21:11 2010 New Revision: 13030 Log: Fix compiler warning about *gpg-program* being assumed special. Modified: trunk/abcl/contrib/asdf-install/port.lisp trunk/abcl/contrib/asdf-install/variables.lisp Modified: trunk/abcl/contrib/asdf-install/port.lisp ============================================================================== --- trunk/abcl/contrib/asdf-install/port.lisp (original) +++ trunk/abcl/contrib/asdf-install/port.lisp Fri Nov 19 13:21:11 2010 @@ -1,10 +1,18 @@ (in-package #:asdf-install) -(defvar *temporary-files*) - +;;; 'port.lisp' is loaded before 'variables.lisp' primarily for the +;;; definiton of GET-ENV-VAR, but still needs the following specials +;;; which would otherwise be in 'variables.lisp'. (defparameter *shell-path* "/bin/sh" "The path to a Bourne compatible command shell in physical pathname notation.") +(defvar *gpg-command* "gpg" + "Location of the gpg binary, if for some reason, it does not appear + in the default path for /bin/sh.") +;;; End variables + +(defvar *temporary-files*) + (eval-when (:load-toplevel :compile-toplevel :execute) #+:allegro (require :osi) Modified: trunk/abcl/contrib/asdf-install/variables.lisp ============================================================================== --- trunk/abcl/contrib/asdf-install/variables.lisp (original) +++ trunk/abcl/contrib/asdf-install/variables.lisp Fri Nov 19 13:21:11 2010 @@ -114,9 +114,3 @@ (defvar *temporary-directory* (pathname-sans-name+type (user-homedir-pathname))) - -(defvar *gpg-command* "gpg" - "Location of the gpg binary, if for some reason, it does appear in - the default path for /bin/sh.") - - From mevenson at common-lisp.net Fri Nov 19 18:23:33 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 19 Nov 2010 13:23:33 -0500 Subject: [armedbear-cvs] r13031 - trunk/abcl/contrib/asdf-install Message-ID: Author: mevenson Date: Fri Nov 19 13:23:31 2010 New Revision: 13031 Log: Ensure that the ASDF registry contains the ASDF-INSTALL install locations. Modified: trunk/abcl/contrib/asdf-install/variables.lisp Modified: trunk/abcl/contrib/asdf-install/variables.lisp ============================================================================== --- trunk/abcl/contrib/asdf-install/variables.lisp (original) +++ trunk/abcl/contrib/asdf-install/variables.lisp Fri Nov 19 13:23:31 2010 @@ -114,3 +114,9 @@ (defvar *temporary-directory* (pathname-sans-name+type (user-homedir-pathname))) + +#+abcl +(eval-when (:load-toplevel) + (require 'asdf) + (dolist (location *locations*) + (pushnew (second location) asdf:*central-registry*))) From astalla at common-lisp.net Sat Nov 20 10:02:29 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sat, 20 Nov 2010 05:02:29 -0500 Subject: [armedbear-cvs] r13032 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sat Nov 20 05:02:27 2010 New Revision: 13032 Log: Fix DEFUN as redefined by the precompiler: it incorrectly returned the function's docstring instead of its name when the docstring was present. Reported by Pascal Bourguignon and Erik Huelsmann on the mailing list. 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 Sat Nov 20 05:02:27 2010 @@ -1165,8 +1165,8 @@ (setf env nil)) (when (null env) (setf lambda-expression (precompiler:precompile-form lambda-expression nil))) - `(progn - (%defun ',name ,lambda-expression) + `(prog1 + (%defun ',name ,lambda-expression) ,@(when doc `((%set-documentation ',name 'function ,doc))))))))) From mevenson at common-lisp.net Sat Nov 20 14:37:02 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Nov 2010 09:37:02 -0500 Subject: [armedbear-cvs] r13033 - in branches/0.23.x/abcl: . src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Sat Nov 20 09:36:57 2010 New Revision: 13033 Log: [ticket #110][backport r13024,r13026] Fix #\+ in JAR pathnames. Modified: branches/0.23.x/abcl/CHANGES branches/0.23.x/abcl/src/org/armedbear/lisp/Pathname.java branches/0.23.x/abcl/test/lisp/abcl/jar-pathname.lisp branches/0.23.x/abcl/test/lisp/abcl/pathname-tests.lisp Modified: branches/0.23.x/abcl/CHANGES ============================================================================== --- branches/0.23.x/abcl/CHANGES (original) +++ branches/0.23.x/abcl/CHANGES Sat Nov 20 09:36:57 2010 @@ -16,6 +16,8 @@ Fixes ----- +* [ticket #110][svn r13024,r13026] Fix #\+ in JAR pathnames does not work + * [svn r12995-12997] Changes to generated byte code to prevent JRockit JVM from crashing when optimizing it Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/Pathname.java Sat Nov 20 09:36:57 2010 @@ -196,26 +196,18 @@ public Pathname(URL url) { if ("file".equals(url.getProtocol())) { - 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 - Debug.assertTrue(false); - s = null; - } + String s = url.getPath(); if (s != null) { - if (Utilities.isPlatformWindows) { - // Workaround for Java's idea of URLs - // new (URL"file:///c:/a/b").getPath() --> "/c:/a/b" + if (Utilities.isPlatformWindows) { + // Workaround for Java's idea of URLs + // new (URL"file:///c:/a/b").getPath() --> "/c:/a/b" // whereas we need "c" to be the DEVICE. - if (s.length() > 2 - && s.charAt(0) == '/' - && s.charAt(2) == ':') { - s = s.substring(1); - } - } + if (s.length() > 2 + && s.charAt(0) == '/' + && s.charAt(2) == ':') { + s = s.substring(1); + } + } init(s); return; } @@ -651,13 +643,13 @@ sb.append('.'); if (type instanceof AbstractString) { String t = type.getStringValue(); - // Allow Windows shortcuts to include TYPE - if (!(t.endsWith(".lnk") && Utilities.isPlatformWindows)) { - if (t.indexOf('.') >= 0) { - Debug.assertTrue(namestring == null); - return null; - } - } + // Allow Windows shortcuts to include TYPE + if (!(t.endsWith(".lnk") && Utilities.isPlatformWindows)) { + if (t.indexOf('.') >= 0) { + Debug.assertTrue(namestring == null); + return null; + } + } sb.append(t); } else if (type == Keyword.WILD) { sb.append('*'); @@ -2093,12 +2085,12 @@ result = Utilities.getEntryAsInputStream(zipInputStream, entryPath); } else { ZipEntry entry = jarFile.getEntry(entryPath); - if (entry == null) { - Debug.trace("Failed to get InputStream for " - + "'" + getNamestring() + "'"); + if (entry == null) { + Debug.trace("Failed to get InputStream for " + + "'" + getNamestring() + "'"); // XXX should this be fatal? - Debug.assertTrue(false); - } + Debug.assertTrue(false); + } try { result = jarFile.getInputStream(entry); } catch (IOException e) { @@ -2267,7 +2259,7 @@ final File destination = new File(newNamestring); if (Utilities.isPlatformWindows) { if (destination.isFile()) { - ZipCache.remove(destination); + ZipCache.remove(destination); destination.delete(); } } @@ -2327,19 +2319,19 @@ } public URL toURL() throws MalformedURLException { - if(isURL()) { - return new URL(getNamestring()); - } else { - return toFile().toURL(); - } + if(isURL()) { + return new URL(getNamestring()); + } else { + return toFile().toURL(); + } } public File toFile() { - if(!isURL()) { - return new File(getNamestring()); - } else { - throw new RuntimeException(this + " does not represent a file"); - } + if(!isURL()) { + return new File(getNamestring()); + } else { + throw new RuntimeException(this + " does not represent a file"); + } } static { Modified: branches/0.23.x/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- branches/0.23.x/abcl/test/lisp/abcl/jar-pathname.lisp (original) +++ branches/0.23.x/abcl/test/lisp/abcl/jar-pathname.lisp Sat Nov 20 09:36:57 2010 @@ -39,29 +39,32 @@ (compile-file "foo.lisp") (compile-file "bar.lisp") (compile-file "eek.lisp") - (let* ((dir (merge-pathnames "tmp/" *abcl-test-directory*)) - (sub (merge-pathnames "a/b/" dir))) - (when (probe-directory dir) - (delete-directory-and-files dir)) - (ensure-directories-exist sub) - (sys:unzip (merge-pathnames "foo.abcl") - dir) - (sys:unzip (merge-pathnames "foo.abcl") - sub) + (let* ((tmpdir (merge-pathnames "tmp/" *abcl-test-directory*)) + (subdirs + (mapcar (lambda (p) (merge-pathnames p tmpdir)) + '("a/b/" "d/e+f/"))) + (sub1 (first subdirs)) + (sub2 (second subdirs))) + (when (probe-directory tmpdir) + (delete-directory-and-files tmpdir)) + (mapcar (lambda (p) (ensure-directories-exist p)) subdirs) + (sys:unzip (merge-pathnames "foo.abcl") tmpdir) + (sys:unzip (merge-pathnames "foo.abcl") sub1) (cl-fad-copy-file (merge-pathnames "bar.abcl") - (merge-pathnames "bar.abcl" dir)) + (merge-pathnames "bar.abcl" tmpdir)) (cl-fad-copy-file (merge-pathnames "bar.abcl") - (merge-pathnames "bar.abcl" sub)) + (merge-pathnames "bar.abcl" sub1)) + (cl-fad-copy-file (merge-pathnames "bar.abcl") + (merge-pathnames "bar.abcl" sub2)) (cl-fad-copy-file (merge-pathnames "eek.lisp") - (merge-pathnames "eek.lisp" dir)) + (merge-pathnames "eek.lisp" tmpdir)) (cl-fad-copy-file (merge-pathnames "eek.lisp") - (merge-pathnames "eek.lisp" sub)) + (merge-pathnames "eek.lisp" sub1)) (sys:zip (merge-pathnames "baz.jar") - (append - (directory (merge-pathnames "*" dir)) - (directory (merge-pathnames "*" sub))) - dir) - (delete-directory-and-files dir))) + (loop :for p :in (list tmpdir sub1 sub2) + :appending (directory (merge-pathnames "*" p))) + tmpdir) + #+nil (delete-directory-and-files dir))) (setf *jar-file-init* t)) (defmacro with-jar-file-init (&rest body) @@ -121,6 +124,11 @@ (load "jar:file:baz.jar!/a/b/eek.lisp")) t) +(deftest jar-pathname.load.11 + (with-jar-file-init + (load "jar:file:baz.jar!/d/e+f/bar.abcl")) + t) + ;;; wrapped in PROGN for easy disabling without a network connection ;;; XXX come up with a better abstraction @@ -131,43 +139,43 @@ `(load (format nil "~A~A" *url-jar-pathname-base* ,path))) (progn - (deftest jar-pathname.load.11 + (deftest jar-pathname.load.http.1 (load-url-relative "foo") t) - (deftest jar-pathname.load.12 + (deftest jar-pathname.load.http.2 (load-url-relative "bar") t) - (deftest jar-pathname.load.13 + (deftest jar-pathname.load.http.3 (load-url-relative "bar.abcl") t) - (deftest jar-pathname.load.14 + (deftest jar-pathname.load.http.4 (load-url-relative "eek") t) - (deftest jar-pathname.load.15 + (deftest jar-pathname.load.http.5 (load-url-relative "eek.lisp") t) - (deftest jar-pathname.load.16 + (deftest jar-pathname.load.http.6 (load-url-relative "a/b/foo") t) - (deftest jar-pathname.load.17 + (deftest jar-pathname.load.http.7 (load-url-relative "a/b/bar") t) - (deftest jar-pathname.load.18 + (deftest jar-pathname.load.http.8 (load-url-relative "a/b/bar.abcl") t) - (deftest jar-pathname.load.19 + (deftest jar-pathname.load.http.9 (load-url-relative "a/b/eek") t) - (deftest jar-pathname.load.20 + (deftest jar-pathname.load.http.10 (load-url-relative "a/b/eek.lisp") t)) @@ -192,7 +200,8 @@ (deftest jar-pathname.probe-file.4 (with-jar-file-init (probe-file "jar:file:baz.jar!/a/b")) - nil) + #p#.(format nil "jar:file:~Abaz.jar!/a/b/" + (namestring *abcl-test-directory*))) (deftest jar-pathname.probe-file.5 (with-jar-file-init @@ -200,6 +209,12 @@ #p#.(format nil "jar:file:~Abaz.jar!/a/b/" (namestring *abcl-test-directory*))) +(deftest jar-pathname.probe-file.6 + (with-jar-file-init + (probe-file "jar:file:baz.jar!/d/e+f/bar.abcl")) + #p#.(format nil "jar:file:~Abaz.jar!/d/e+f/bar.abcl" + (namestring *abcl-test-directory*))) + (deftest jar-pathname.merge-pathnames.1 (merge-pathnames "/bar.abcl" #p"jar:file:baz.jar!/foo") @@ -326,6 +341,19 @@ (:relative "a" "b") "foo" "jar" (:absolute "c" "d") "foo" "lisp") +(deftest jar-pathname.10 + (let ((s "jar:file:/foo/bar/a space/that!/this")) + (equal s + (namestring (pathname s)))) + t) + +(deftest jar-pathname.11 + (let ((s "jar:file:/foo/bar/a+space/that!/this")) + (equal s + (namestring (pathname s)))) + t) + + (deftest jar-pathname.match-p.1 (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd" "jar:file:/**/*.jar!/**/*.asd") Modified: branches/0.23.x/abcl/test/lisp/abcl/pathname-tests.lisp ============================================================================== --- branches/0.23.x/abcl/test/lisp/abcl/pathname-tests.lisp (original) +++ branches/0.23.x/abcl/test/lisp/abcl/pathname-tests.lisp Sat Nov 20 09:36:57 2010 @@ -438,6 +438,21 @@ (equal #p"c:\\foo.bar" #p"C:\\FOO.BAR") t) +#+windows +(deftest pathname.windows.6 + (equal (pathname-device #p"z:/foo/bar") "z") + t) + +#+windows +(deftest pathname.windows.7 + (equal (pathname-device #p"file:z:/foo/bar") "z") + t) + +#+windows +(deftest pathname.windows.8 + (equal (pathname-device #p"zoo:/foo/bar") nil) + t) + (deftest wild.1 (check-physical-pathname #p"foo.*" nil "foo" :wild) t) From mevenson at common-lisp.net Sat Nov 20 15:18:21 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Nov 2010 10:18:21 -0500 Subject: [armedbear-cvs] r13034 - trunk/abcl/contrib/asdf-install Message-ID: Author: mevenson Date: Sat Nov 20 10:18:21 2010 New Revision: 13034 Log: ASDF-INSTALL now uses the path search mechanism for 'gpg'. Expand the searched paths to a more plausible set, adding '/usr/local/bin' and '/opt/local/bin'. Increment ASDF-INSTALL version to 0.6.10-ABCL.1 to note recent fixes. Modified: trunk/abcl/contrib/asdf-install/asdf-install.asd trunk/abcl/contrib/asdf-install/port.lisp trunk/abcl/contrib/asdf-install/variables.lisp Modified: trunk/abcl/contrib/asdf-install/asdf-install.asd ============================================================================== --- trunk/abcl/contrib/asdf-install/asdf-install.asd (original) +++ trunk/abcl/contrib/asdf-install/asdf-install.asd Sat Nov 20 10:18:21 2010 @@ -12,7 +12,7 @@ (defsystem asdf-install #+:sbcl :depends-on #+:sbcl (sb-bsd-sockets) - :version "0.6.10-ABCL.0" + :version "0.6.10-ABCL.1" :author "Dan Barlow , Edi Weitz and many others. See the file COPYRIGHT for more details." :maintainer "Gary Warren King " :components ((:file "defpackage") Modified: trunk/abcl/contrib/asdf-install/port.lisp ============================================================================== --- trunk/abcl/contrib/asdf-install/port.lisp (original) +++ trunk/abcl/contrib/asdf-install/port.lisp Sat Nov 20 10:18:21 2010 @@ -384,12 +384,15 @@ (pushnew tmp *temporary-files*) (values (download-url-to-file url tmp) tmp))) +(defun gpg-command () + (find-shell-command *gpg-command*)) + (defun gpg-results (package signature) (let ((tags nil)) (with-input-from-string (gpg-stream (shell-command (format nil "~s --status-fd 1 --verify ~s ~s" - *gpg-command* + (gpg-command) (namestring signature) (namestring package)))) (loop for l = (read-line gpg-stream nil nil) while l Modified: trunk/abcl/contrib/asdf-install/variables.lisp ============================================================================== --- trunk/abcl/contrib/asdf-install/variables.lisp (original) +++ trunk/abcl/contrib/asdf-install/variables.lisp Sat Nov 20 10:18:21 2010 @@ -48,7 +48,9 @@ ;; bin first (defvar *shell-search-paths* '((:absolute "bin") - (:absolute "usr" "bin")) + (:absolute "usr" "bin") + (:absolute "usr" "local" "bin") + (:absolute "opt" "local" "bin")) "A list of places to look for shell commands.") (defvar *gnu-tar-program* From mevenson at common-lisp.net Sat Nov 20 15:30:11 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Nov 2010 10:30:11 -0500 Subject: [armedbear-cvs] r13035 - in branches/0.23.x/abcl: . contrib/asdf-install Message-ID: Author: mevenson Date: Sat Nov 20 10:30:10 2010 New Revision: 13035 Log: [ticket #108][svn r13027] Fix download problems with ASDF-INSTALL. Modified: branches/0.23.x/abcl/CHANGES branches/0.23.x/abcl/contrib/asdf-install/installer.lisp branches/0.23.x/abcl/contrib/asdf-install/port.lisp branches/0.23.x/abcl/contrib/asdf-install/variables.lisp Modified: branches/0.23.x/abcl/CHANGES ============================================================================== --- branches/0.23.x/abcl/CHANGES (original) +++ branches/0.23.x/abcl/CHANGES Sat Nov 20 10:30:10 2010 @@ -16,6 +16,8 @@ Fixes ----- +* [ticket #108][svn r13027] Fix download problems with ASDF-INSTALL + * [ticket #110][svn r13024,r13026] Fix #\+ in JAR pathnames does not work * [svn r12995-12997] Changes to generated byte code to prevent JRockit JVM Modified: branches/0.23.x/abcl/contrib/asdf-install/installer.lisp ============================================================================== --- branches/0.23.x/abcl/contrib/asdf-install/installer.lisp (original) +++ branches/0.23.x/abcl/contrib/asdf-install/installer.lisp Sat Nov 20 10:30:10 2010 @@ -302,7 +302,7 @@ (defun tar-arguments (source packagename) #-(or :win32 :mswindows :scl) - (list "-C" (namestring (truename source)) + (list "-C" (namestring (truename source)) "-xzvf" (namestring (truename packagename))) #+(or :win32 :mswindows) (list "-l" @@ -311,7 +311,7 @@ (namestring (truename source)) (namestring (truename packagename)))) #+scl - (list "-C" (ext:unix-namestring (truename source)) + (list "-C" (ext:unix-namestring (truename source)) "-xzvf" (ext:unix-namestring (truename packagename)))) (defun extract-using-tar (to-dir tarball) @@ -333,7 +333,7 @@ (let* ((tar (extract source packagename)) ;; Some tar programs (OSX) list entries with preceeding "x " ;; as in "x entry/file.asd" - (pos-begin (if (= (search "x " tar) 0) + (pos-begin (if (string= (subseq tar 0 2) "x ") 2 0)) (pos-slash (or (position #\/ tar) @@ -344,7 +344,6 @@ (make-pathname :directory `(:relative ,(subseq tar pos-begin pos-slash))) source))) - ;(princ tar) (loop for sysfile in (append (directory (make-pathname :defaults *default-pathname-defaults* Modified: branches/0.23.x/abcl/contrib/asdf-install/port.lisp ============================================================================== --- branches/0.23.x/abcl/contrib/asdf-install/port.lisp (original) +++ branches/0.23.x/abcl/contrib/asdf-install/port.lisp Sat Nov 20 10:30:10 2010 @@ -144,7 +144,7 @@ #+:abcl (let ((socket (ext:make-socket (url-host url) (url-port url)))) - (ext:get-socket-stream socket))) + (ext:get-socket-stream socket :external-format :iso-8859-1))) #+:sbcl @@ -322,6 +322,8 @@ '(:external-format :latin1) #+:scl '(:external-format :iso-8859-1) + #+abcl + '(:external-format :iso-8859-1) #+(or :clisp :digitool (and :lispworks :win32)) '(:element-type (unsigned-byte 8)))) Modified: branches/0.23.x/abcl/contrib/asdf-install/variables.lisp ============================================================================== --- branches/0.23.x/abcl/contrib/asdf-install/variables.lisp (original) +++ branches/0.23.x/abcl/contrib/asdf-install/variables.lisp Sat Nov 20 10:30:10 2010 @@ -52,8 +52,8 @@ "A list of places to look for shell commands.") (defvar *gnu-tar-program* - #-(or :netbsd :freebsd :solaris) "tar" - #+(or :netbsd :freebsd :solaris) "gtar" + #-(or :netbsd :freebsd :solaris :sunos) "tar" + #+(or :netbsd :freebsd :solaris :sunos) "gtar" "Path to the GNU tar program") (eval-when (:compile-toplevel :load-toplevel :execute) From mevenson at common-lisp.net Sat Nov 20 15:31:15 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Nov 2010 10:31:15 -0500 Subject: [armedbear-cvs] r13036 - branches/0.23.x/abcl Message-ID: Author: mevenson Date: Sat Nov 20 10:31:14 2010 New Revision: 13036 Log: [backport r13029] Ensure that build process exits with error if abcl.contrib.compile fails. Modified: branches/0.23.x/abcl/build.xml Modified: branches/0.23.x/abcl/build.xml ============================================================================== --- branches/0.23.x/abcl/build.xml (original) +++ branches/0.23.x/abcl/build.xml Sat Nov 20 10:31:14 2010 @@ -379,15 +379,17 @@ - + + + + From mevenson at common-lisp.net Sat Nov 20 15:38:04 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Nov 2010 10:38:04 -0500 Subject: [armedbear-cvs] r13037 - in branches/0.23.x/abcl: . contrib/asdf-install Message-ID: Author: mevenson Date: Sat Nov 20 10:38:03 2010 New Revision: 13037 Log: [backport r13030,r13031] Ensure ASDF registry contains ASDF-INSTALL locations. Fix compiler warning about *gpg-program* being assumed special. Modified: branches/0.23.x/abcl/CHANGES branches/0.23.x/abcl/contrib/asdf-install/port.lisp branches/0.23.x/abcl/contrib/asdf-install/variables.lisp Modified: branches/0.23.x/abcl/CHANGES ============================================================================== --- branches/0.23.x/abcl/CHANGES (original) +++ branches/0.23.x/abcl/CHANGES Sat Nov 20 10:38:03 2010 @@ -13,6 +13,8 @@ * [svn r12994] New java-interop macros: CHAIN and JMETHOD-LET +* [svn r13031] Ensure that the ASDF registry contains the ASDF-INSTALL locations. + Fixes ----- Modified: branches/0.23.x/abcl/contrib/asdf-install/port.lisp ============================================================================== --- branches/0.23.x/abcl/contrib/asdf-install/port.lisp (original) +++ branches/0.23.x/abcl/contrib/asdf-install/port.lisp Sat Nov 20 10:38:03 2010 @@ -1,10 +1,18 @@ (in-package #:asdf-install) -(defvar *temporary-files*) - +;;; 'port.lisp' is loaded before 'variables.lisp' primarily for the +;;; definiton of GET-ENV-VAR, but still needs the following specials +;;; which would otherwise be in 'variables.lisp'. (defparameter *shell-path* "/bin/sh" "The path to a Bourne compatible command shell in physical pathname notation.") +(defvar *gpg-command* "gpg" + "Location of the gpg binary, if for some reason, it does not appear + in the default path for /bin/sh.") +;;; End variables + +(defvar *temporary-files*) + (eval-when (:load-toplevel :compile-toplevel :execute) #+:allegro (require :osi) Modified: branches/0.23.x/abcl/contrib/asdf-install/variables.lisp ============================================================================== --- branches/0.23.x/abcl/contrib/asdf-install/variables.lisp (original) +++ branches/0.23.x/abcl/contrib/asdf-install/variables.lisp Sat Nov 20 10:38:03 2010 @@ -115,8 +115,8 @@ (defvar *temporary-directory* (pathname-sans-name+type (user-homedir-pathname))) -(defvar *gpg-command* "gpg" - "Location of the gpg binary, if for some reason, it does appear in - the default path for /bin/sh.") - - +#+abcl +(eval-when (:load-toplevel) + (require 'asdf) + (dolist (location *locations*) + (pushnew (second location) asdf:*central-registry*))) From mevenson at common-lisp.net Sat Nov 20 15:41:56 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Nov 2010 10:41:56 -0500 Subject: [armedbear-cvs] r13038 - in branches/0.23.x/abcl: . contrib/asdf-install Message-ID: Author: mevenson Date: Sat Nov 20 10:41:55 2010 New Revision: 13038 Log: [backport r13034] Better resolution mechanism for 'gpg' binary. Modified: branches/0.23.x/abcl/CHANGES branches/0.23.x/abcl/contrib/asdf-install/asdf-install.asd branches/0.23.x/abcl/contrib/asdf-install/port.lisp branches/0.23.x/abcl/contrib/asdf-install/variables.lisp Modified: branches/0.23.x/abcl/CHANGES ============================================================================== --- branches/0.23.x/abcl/CHANGES (original) +++ branches/0.23.x/abcl/CHANGES Sat Nov 20 10:41:55 2010 @@ -13,7 +13,9 @@ * [svn r12994] New java-interop macros: CHAIN and JMETHOD-LET -* [svn r13031] Ensure that the ASDF registry contains the ASDF-INSTALL locations. +* [svn r13030-31,r13034] ASDF-INSTALL improvements: Ensure that the + ASDF registry contains the ASDF-INSTALL locations. Better + resolution mechanism for 'gpg' binary. Fixes ----- Modified: branches/0.23.x/abcl/contrib/asdf-install/asdf-install.asd ============================================================================== --- branches/0.23.x/abcl/contrib/asdf-install/asdf-install.asd (original) +++ branches/0.23.x/abcl/contrib/asdf-install/asdf-install.asd Sat Nov 20 10:41:55 2010 @@ -12,7 +12,7 @@ (defsystem asdf-install #+:sbcl :depends-on #+:sbcl (sb-bsd-sockets) - :version "0.6.10-ABCL.0" + :version "0.6.10-ABCL.1" :author "Dan Barlow , Edi Weitz and many others. See the file COPYRIGHT for more details." :maintainer "Gary Warren King " :components ((:file "defpackage") Modified: branches/0.23.x/abcl/contrib/asdf-install/port.lisp ============================================================================== --- branches/0.23.x/abcl/contrib/asdf-install/port.lisp (original) +++ branches/0.23.x/abcl/contrib/asdf-install/port.lisp Sat Nov 20 10:41:55 2010 @@ -384,12 +384,15 @@ (pushnew tmp *temporary-files*) (values (download-url-to-file url tmp) tmp))) +(defun gpg-command () + (find-shell-command *gpg-command*)) + (defun gpg-results (package signature) (let ((tags nil)) (with-input-from-string (gpg-stream (shell-command (format nil "~s --status-fd 1 --verify ~s ~s" - *gpg-command* + (gpg-command) (namestring signature) (namestring package)))) (loop for l = (read-line gpg-stream nil nil) while l Modified: branches/0.23.x/abcl/contrib/asdf-install/variables.lisp ============================================================================== --- branches/0.23.x/abcl/contrib/asdf-install/variables.lisp (original) +++ branches/0.23.x/abcl/contrib/asdf-install/variables.lisp Sat Nov 20 10:41:55 2010 @@ -48,7 +48,9 @@ ;; bin first (defvar *shell-search-paths* '((:absolute "bin") - (:absolute "usr" "bin")) + (:absolute "usr" "bin") + (:absolute "usr" "local" "bin") + (:absolute "opt" "local" "bin")) "A list of places to look for shell commands.") (defvar *gnu-tar-program* From mevenson at common-lisp.net Sat Nov 20 16:38:02 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Nov 2010 11:38:02 -0500 Subject: [armedbear-cvs] r13039 - trunk/abcl Message-ID: Author: mevenson Date: Sat Nov 20 11:38:01 2010 New Revision: 13039 Log: Fix Lisp-based build (reported by Pascal J. Bourguignon). Modified: trunk/abcl/build-abcl.lisp Modified: trunk/abcl/build-abcl.lisp ============================================================================== --- trunk/abcl/build-abcl.lisp (original) +++ trunk/abcl/build-abcl.lisp Sat Nov 20 11:38:01 2010 @@ -372,7 +372,7 @@ '(("\\" . "/"))))) (cmdline (format nil "~A -cp build/classes -Dabcl.home=\"~A\" ~ -org.armedbear.lisp.Main --noinit ~ +org.armedbear.lisp.Main --noinit --nosystem ~ --eval \"(compile-system :zip ~A :quit t :output-path \\\"~A\\\")\"~%" java-namestring abcl-home From mevenson at common-lisp.net Sat Nov 20 16:51:27 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Nov 2010 11:51:27 -0500 Subject: [armedbear-cvs] r13040 - branches/0.23.x/abcl Message-ID: Author: mevenson Date: Sat Nov 20 11:51:27 2010 New Revision: 13040 Log: [backport r13039] Restore Lisp-based build. Modified: branches/0.23.x/abcl/CHANGES branches/0.23.x/abcl/build-abcl.lisp Modified: branches/0.23.x/abcl/CHANGES ============================================================================== --- branches/0.23.x/abcl/CHANGES (original) +++ branches/0.23.x/abcl/CHANGES Sat Nov 20 11:51:27 2010 @@ -20,6 +20,8 @@ Fixes ----- +* [svn r13039] Restore the Lisp-based build + * [ticket #108][svn r13027] Fix download problems with ASDF-INSTALL * [ticket #110][svn r13024,r13026] Fix #\+ in JAR pathnames does not work Modified: branches/0.23.x/abcl/build-abcl.lisp ============================================================================== --- branches/0.23.x/abcl/build-abcl.lisp (original) +++ branches/0.23.x/abcl/build-abcl.lisp Sat Nov 20 11:51:27 2010 @@ -372,7 +372,7 @@ '(("\\" . "/"))))) (cmdline (format nil "~A -cp build/classes -Dabcl.home=\"~A\" ~ -org.armedbear.lisp.Main --noinit ~ +org.armedbear.lisp.Main --noinit --nosystem ~ --eval \"(compile-system :zip ~A :quit t :output-path \\\"~A\\\")\"~%" java-namestring abcl-home From mevenson at common-lisp.net Sun Nov 21 19:40:28 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 21 Nov 2010 14:40:28 -0500 Subject: [armedbear-cvs] r13041 - trunk/abcl Message-ID: Author: mevenson Date: Sun Nov 21 14:40:25 2010 New Revision: 13041 Log: Reworked Lisp-based build now works for ecl. Based on a patch from Pascal J. Bourguignon. Refactored elements of Lisp-based build to improve error handling and present more of a informative view of what is occuring. Modified: trunk/abcl/build-abcl.lisp trunk/abcl/build-from-lisp.sh (contents, props changed) Modified: trunk/abcl/build-abcl.lisp ============================================================================== --- trunk/abcl/build-abcl.lisp (original) +++ trunk/abcl/build-abcl.lisp Sun Nov 21 14:40:25 2010 @@ -21,8 +21,7 @@ string))) (defun safe-namestring (pathname) - (let* ((string (namestring pathname)) - (len (length string))) + (let ((string (namestring pathname))) (when (position #\space string) (setf string (concatenate 'string "\"" (comp string #\\) @@ -69,9 +68,9 @@ #+clisp (cond ((member :win32 *features*) :windows) - ((zerop (ext:run-shell-command "uname | grep -i darwin" :output nil)) + ((equal 0 (ext:run-shell-command "uname | grep -i darwin" :output nil)) :darwin) - ((zerop (ext:run-shell-command "uname | grep -i linux" :output nil)) + ((equal 0 (ext:run-shell-command "uname | grep -i linux" :output nil)) :linux) (t :unknown))) @@ -94,7 +93,7 @@ "\" && " command))) (sb-ext:process-exit-code - (sb-ext:run-program + (sb-ext:run-program "/bin/sh" (list "-c" command) :input nil :output output))) @@ -168,7 +167,28 @@ (declare (ignore status)) exitcode)) -#+(or sbcl cmu lispworks openmcl) +#+ecl +(defun run-shell-command (command &key directory (output *standard-output*)) + (when directory + (if (member :windows *features*) + (error "Unimplemented.") + (setf command (concatenate 'string + "\\cd \"" + (namestring (pathname directory)) + "\" && " + command)))) + (ext:system command)) + ;; (multiple-value-bind (stream exit details) + ;; (ext:run-program + ;; "/bin/sh" (list "-c" command) + ;; :input nil :output :stream :error :output) + ;; (declare (ignore details)) + ;; (loop for line = (read-line stream nil) + ;; while line do (format output "~A~%" line)) + ;; exit)) + + +#+(or sbcl cmu lispworks openmcl ecl) (defun probe-directory (pathspec) (let* ((truename (probe-file pathspec)) ; TRUENAME is a pathname. (namestring (and truename (namestring truename)))) ; NAMESTRING is a string. @@ -285,9 +305,9 @@ (defun java-compile-file (source-file) (let ((cmdline (build-javac-command-line source-file))) - (zerop (run-shell-command cmdline :directory *abcl-dir*)))) + (equal 0 (run-shell-command cmdline :directory *abcl-dir*)))) -(defun make-classes (force batch) +(defun do-compile-classes (force batch) (let* ((source-files (remove-if-not #'(lambda (name) @@ -299,14 +319,11 @@ *build-root*))) (or force (file-newer name output-name)))) - (mapcan #'(lambda (default) - (directory (merge-pathnames "*.java" - default))) - (list *abcl-dir* - (merge-pathnames "util/" *abcl-dir*)))))) + (directory (merge-pathnames "**/*.java" *source-root*))))) (format t "~&JDK: ~A~%" *jdk*) (format t "Java compiler: ~A~%" *java-compiler*) (format t "Compiler options: ~A~%~%" (if *java-compiler-options* *java-compiler-options* "")) + (format t "~&Compiling Java sources...") (finish-output) (cond ((null source-files) (format t "Classes are up to date.~%") @@ -315,22 +332,17 @@ (t (cond (batch (ensure-directories-exist *build-root*) - (let* ((dir (pathname-directory *abcl-dir*)) - (cmdline (with-output-to-string (s) + (let* ((cmdline (with-output-to-string (s) (princ *java-compiler-command-line-prefix* s) (princ " -d " s) (princ (safe-namestring *build-root*) s) (princ #\Space s) (dolist (source-file source-files) - (princ - (safe-namestring - (if (equal (pathname-directory source-file) dir) - (file-namestring source-file) - (namestring source-file))) - s) + (princ (safe-namestring (namestring source-file)) s) (princ #\space s)))) - (status (run-shell-command cmdline :directory *abcl-dir*))) - (zerop status))) + (status (run-shell-command cmdline :directory *tree-root*))) + (format t " done.~%") + (equal 0 status))) (t (ensure-directories-exist *build-root*) (dolist (source-file source-files t) @@ -350,11 +362,12 @@ (copy-with-substitutions source-file target-file substitutions-alist) (ensure-directories-exist *dist-root*) (let ((status (run-shell-command command :directory *tree-root*))) - (unless (zerop status) + (unless (equal 0 status) (format t "~A returned ~S~%" command status)) status)))) (defun do-compile-system (&key (zip t)) + (format t "~&Compiling Lisp sources...") (terpri) (finish-output) (let* ((java-namestring (safe-namestring *java*)) @@ -379,9 +392,8 @@ (not (not zip)) ;; because that ensures T or NIL output-path))) (ensure-directories-exist output-path) - (setf status - (run-shell-command cmdline - :directory *tree-root*)) + (setf status (run-shell-command cmdline :directory *tree-root*)) + (format t " done.~%") status)) @@ -433,6 +445,7 @@ (delete-file truename))))) (defun clean () + (format t "~&Cleaning compilation results." (dolist (f (list (list *tree-root* "abcl.jar" "abcl.bat" "make-jar.bat" "compile-system.bat") ;; as of 0.14 'compile-system.bat' isn't created anymore @@ -481,21 +494,21 @@ ;; clean (when clean (clean)) - ;; classes - (unless (make-classes force batch) + ;; Compile Java source into classes + (unless (do-compile-classes force batch) (format t "Build failed.~%") (return-from build-abcl nil)) ;; COMPILE-SYSTEM (when (or full compile-system) (let* ((zip (if (or full jar) nil t)) (status (do-compile-system :zip zip))) - (unless (zerop status) + (unless (equal 0 status) (format t "Build failed.~%") (return-from build-abcl nil)))) ;; abcl.jar (when (or full jar) (let ((status (make-jar))) - (unless (zerop status) + (unless (equal 0 status) (format t "Build failed.~%") (return-from build-abcl nil)))) ;; abcl/abcl.bat @@ -518,7 +531,7 @@ (princ #\space s))) (princ "--main=org.armedbear.lisp.Main -o lisp" s))) (result (run-shell-command cmdline :directory *abcl-dir*))) - (zerop result))) + (equal 0 result))) (defvar *copy-verbose* nil) @@ -591,11 +604,11 @@ (namestring parent-dir) version-string version-string)) (status (run-shell-command command :directory parent-dir))) - (unless (zerop status) + (unless (equal 0 status) (format t "~A returned ~S~%" command status))) (let* ((command (format nil "zip -q -r ~A~A.zip ~A" (namestring parent-dir) version-string version-string)) (status (run-shell-command command :directory parent-dir))) - (unless (zerop status) + (unless (equal 0 status) (format t "~A returned ~S~%" command status))))) Modified: trunk/abcl/build-from-lisp.sh ============================================================================== --- trunk/abcl/build-from-lisp.sh (original) +++ trunk/abcl/build-from-lisp.sh Sun Nov 21 14:40:25 2010 @@ -72,6 +72,11 @@ exec "$1" --load "$2" --eval "(progn $3 (ext:quit))" } +ecl() +{ + exec "$1" -norc -load "$2" -eval "(progn $3 (ext:quit))" +} + clisp() { exec "$1" -ansi -q -norc -i "$2" -x "(progn $3 (ext:quit))" @@ -120,7 +125,7 @@ gcl*) notimplemented "$IMPL" "$FILE" "$FORM" ;; ecl*) - notimplemented "$IMPL" "$FILE" "$FORM" ;; + ecl "$IMPL" "$FILE" "$FORM" ;; alisp*) notimplemented "$IMPL" "$FILE" "$FORM" ;; *) From mevenson at common-lisp.net Mon Nov 22 08:56:27 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 22 Nov 2010 03:56:27 -0500 Subject: [armedbear-cvs] r13042 - trunk/abcl Message-ID: Author: mevenson Date: Mon Nov 22 03:56:24 2010 New Revision: 13042 Log: Fix typo in Lisp-based build. Modified: trunk/abcl/build-abcl.lisp Modified: trunk/abcl/build-abcl.lisp ============================================================================== --- trunk/abcl/build-abcl.lisp (original) +++ trunk/abcl/build-abcl.lisp Mon Nov 22 03:56:24 2010 @@ -445,7 +445,7 @@ (delete-file truename))))) (defun clean () - (format t "~&Cleaning compilation results." + (format t "~&Cleaning compilation results.") (dolist (f (list (list *tree-root* "abcl.jar" "abcl.bat" "make-jar.bat" "compile-system.bat") ;; as of 0.14 'compile-system.bat' isn't created anymore From ehuelsmann at common-lisp.net Mon Nov 22 20:19:29 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 22 Nov 2010 15:19:29 -0500 Subject: [armedbear-cvs] r13043 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Nov 22 15:19:27 2010 New Revision: 13043 Log: Fix our line number table generation; put the line number table on the Code attribute instead of on the method itself. 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 Nov 22 15:19:27 2010 @@ -6792,7 +6792,7 @@ (when (fixnump *source-line-number*) (let ((table (make-line-numbers-attribute))) - (method-add-attribute method table) + (code-add-attribute *current-code-attribute* table) (line-numbers-add-line table 0 *source-line-number*))) (dolist (var (compiland-arg-vars compiland)) From ehuelsmann at common-lisp.net Mon Nov 22 20:20:00 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 22 Nov 2010 15:20:00 -0500 Subject: [armedbear-cvs] r13044 - branches/0.23.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Nov 22 15:19:59 2010 New Revision: 13044 Log: Backport line number table fix. Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Nov 22 15:19:59 2010 @@ -6770,7 +6770,7 @@ (class-add-method class-file method) (when (fixnump *source-line-number*) (let ((table (make-line-numbers-attribute))) - (method-add-attribute method table) + (code-add-attribute *current-code-attribute* table) (line-numbers-add-line table 0 *source-line-number*))) (dolist (var (compiland-arg-vars compiland)) From astalla at common-lisp.net Tue Nov 23 20:02:07 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 23 Nov 2010 15:02:07 -0500 Subject: [armedbear-cvs] r13045 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Nov 23 15:02:06 2010 New Revision: 13045 Log: Fix the macroexpansion of DEFUN in compiled files to return the function name instead of the function object. Completes the change introduced with r13032. 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 Nov 23 15:02:06 2010 @@ -1159,7 +1159,9 @@ ;; Both COMPILE and COMPILE-FILE bind this variable. ;; This function is also triggered by MACROEXPAND, though jvm::*file-compilation*) - `(fset ',name ,lambda-expression)) + `(progn + (fset ',name ,lambda-expression) + ',name)) (t (when (and env (empty-environment-p env)) (setf env nil)) From ehuelsmann at common-lisp.net Thu Nov 25 13:15:22 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Nov 2010 08:15:22 -0500 Subject: [armedbear-cvs] r13046 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 25 08:15:18 2010 New Revision: 13046 Log: Fix ANSI regressions caused by the implementation of the new class writer. Found by: Mark Evenson Patch by: me Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp trunk/abcl/src/org/armedbear/lisp/known-symbols.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 Nov 25 08:15:18 2010 @@ -674,7 +674,7 @@ `(case ,expr , at clauses)))) (defconstant +fasl-classloader+ - (jvm::make-class-name "org.armedbear.lisp.FaslClassLoader")) + (jvm::make-jvm-class-name "org.armedbear.lisp.FaslClassLoader")) (defun generate-loader-function () (let* ((basename (base-classname)) @@ -693,7 +693,7 @@ :collect (let* ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)) - (class-name (jvm::make-class-name class))) + (class-name (jvm::make-jvm-class-name class))) `(,(1- i) (jvm::with-inline-code () (jvm::emit-new ,class-name) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Nov 25 08:15:18 2010 @@ -795,8 +795,8 @@ (defun make-constructor (class) (let* ((*compiler-debug* nil) - (method (make-method :constructor :void nil - :flags '(:public))) + (method (make-jvm-method :constructor :void nil + :flags '(:public))) ;; We don't normally need to see debugging output for constructors. (super (class-file-superclass class)) (lambda-name (abcl-class-file-lambda-name class)) @@ -909,8 +909,8 @@ (defun make-static-initializer (class) (let ((*compiler-debug* nil) - (method (make-method :static-initializer - :void nil :flags '(:public :static)))) + (method (make-jvm-method :static-initializer + :void nil :flags '(:public :static)))) ;; We don't normally need to see debugging output for . (with-code-to-method (class method) (setf (code-max-locals *current-code-attribute*) 0) @@ -6761,8 +6761,8 @@ (*child-p* (not (null (compiland-parent compiland)))) (arg-types (analyze-args compiland)) - (method (make-method "execute" +lisp-object+ arg-types - :flags '(:final :public))) + (method (make-jvm-method "execute" +lisp-object+ arg-types + :flags '(:final :public))) (*visible-variables* *visible-variables*) (*thread* nil) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Thu Nov 25 08:15:18 2010 @@ -80,8 +80,8 @@ |# -(defstruct (class-name (:conc-name class-) - (:constructor %make-class-name)) +(defstruct (jvm-class-name (:conc-name class-) + (:constructor %make-jvm-class-name)) "Used for class identification. The caller should instantiate only one `class-name' per class, as they are @@ -96,14 +96,14 @@ ;; name comparisons to be EQ: all classes should exist only once, ) -(defun make-class-name (name) +(defun make-jvm-class-name (name) "Creates a `class-name' structure for the class or interface `name'. `name' should be specified using Java representation, which is converted to 'internal' (JVM) representation by this function." (setf name (substitute #\/ #\. name)) - (%make-class-name :name-internal name - :ref (concatenate 'string "L" name ";"))) + (%make-jvm-class-name :name-internal name + :ref (concatenate 'string "L" name ";"))) (defun class-array (class-name) "Returns a class-name representing an array of `class-name'. @@ -120,14 +120,14 @@ ;; are identified by the same string (let ((name-and-ref (concatenate 'string "[" (class-ref class-name)))) (setf (class-array-class class-name) - (%make-class-name :name-internal name-and-ref - :ref name-and-ref)))) + (%make-jvm-class-name :name-internal name-and-ref + :ref name-and-ref)))) (class-array-class class-name)) (defmacro define-class-name (symbol java-dotted-name &optional documentation) "Convenience macro to define constants for `class-name' structures, initialized from the `java-dotted-name'." - `(defconstant ,symbol (make-class-name ,java-dotted-name) + `(defconstant ,symbol (make-jvm-class-name ,java-dotted-name) ,documentation)) (define-class-name +java-object+ "java.lang.Object") @@ -835,8 +835,8 @@ (write-attributes (field-attributes field) stream)) -(defstruct (method (:constructor %make-method) - (:conc-name method-)) +(defstruct (jvm-method (:constructor %make-jvm-method) + (:conc-name method-)) "Holds information on the properties of methods in the class(-file)." access-flags name @@ -858,11 +858,11 @@ "") (t name))) -(defun make-method (name return args &key (flags '(:public))) +(defun make-jvm-method (name return args &key (flags '(:public))) "Creates a method for addition to a class file." - (%make-method :descriptor (cons return args) - :access-flags flags - :name (map-method-name name))) + (%make-jvm-method :descriptor (cons return args) + :access-flags flags + :name (map-method-name name))) (defun method-add-attribute (method attribute) "Add `attribute' to the list of attributes of `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 Thu Nov 25 08:15:18 2010 @@ -138,13 +138,13 @@ (when (or (char= (char name i) #\-) (char= (char name i) #\Space)) (setf (char name i) #\_))) - (make-class-name + (make-jvm-class-name (concatenate 'string "org.armedbear.lisp." name)))) (defun make-unique-class-name () "Creates a random class name for use with a `class-file' structure's `class' slot." - (make-class-name + (make-jvm-class-name (concatenate 'string "abcl_" (substitute #\_ #\- (java:jcall (java:jmethod "java.util.UUID" Modified: trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp Thu Nov 25 08:15:18 2010 @@ -38,7 +38,7 @@ (let ((symbols (make-hash-table :test 'eq :size 2048))) (defun initialize-known-symbols (source ht) (let* ((source-class (java:jclass source)) - (class-designator (jvm::make-class-name source)) + (class-designator (jvm::make-jvm-class-name source)) (symbol-class (java:jclass "org.armedbear.lisp.Symbol")) (fields (java:jclass-fields source-class :declared t :public t))) (dotimes (i (length fields)) From ehuelsmann at common-lisp.net Thu Nov 25 13:52:52 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Nov 2010 08:52:52 -0500 Subject: [armedbear-cvs] r13047 - branches/0.23.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 25 08:52:51 2010 New Revision: 13047 Log: Backport r13046; ANSI test regressions. Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/compile-file.lisp branches/0.23.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/0.23.x/abcl/src/org/armedbear/lisp/jvm-class-file.lisp branches/0.23.x/abcl/src/org/armedbear/lisp/jvm.lisp branches/0.23.x/abcl/src/org/armedbear/lisp/known-symbols.lisp Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/compile-file.lisp Thu Nov 25 08:52:51 2010 @@ -674,7 +674,7 @@ `(case ,expr , at clauses)))) (defconstant +fasl-classloader+ - (jvm::make-class-name "org.armedbear.lisp.FaslClassLoader")) + (jvm::make-jvm-class-name "org.armedbear.lisp.FaslClassLoader")) (defun generate-loader-function () (let* ((basename (base-classname)) @@ -693,7 +693,7 @@ :collect (let* ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)) - (class-name (jvm::make-class-name class))) + (class-name (jvm::make-jvm-class-name class))) `(,(1- i) (jvm::with-inline-code () (jvm::emit-new ,class-name) Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Nov 25 08:52:51 2010 @@ -796,8 +796,8 @@ (defun make-constructor (super lambda-name args) (let* ((*compiler-debug* nil) ;; We don't normally need to see debugging output for constructors. - (method (make-method :constructor :void nil - :flags '(:public))) + (method (make-jvm-method :constructor :void nil + :flags '(:public))) (code (method-add-code method)) req-params-register opt-params-register @@ -906,7 +906,6 @@ (setf (code-code code) *code*) method)) - (defvar *source-line-number* nil) @@ -6754,7 +6753,7 @@ (*child-p* (not (null (compiland-parent compiland)))) (arg-types (analyze-args compiland)) - (method (make-method "execute" +lisp-object+ arg-types + (method (make-jvm-method "execute" +lisp-object+ arg-types :flags '(:final :public))) (code (method-add-code method)) (*current-code-attribute* code) Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Thu Nov 25 08:52:51 2010 @@ -80,8 +80,8 @@ |# -(defstruct (class-name (:conc-name class-) - (:constructor %make-class-name)) +(defstruct (jvm-class-name (:conc-name class-) + (:constructor %make-jvm-class-name)) "Used for class identification. The caller should instantiate only one `class-name' per class, as they are @@ -96,14 +96,14 @@ ;; name comparisons to be EQ: all classes should exist only once, ) -(defun make-class-name (name) +(defun make-jvm-class-name (name) "Creates a `class-name' structure for the class or interface `name'. `name' should be specified using Java representation, which is converted to 'internal' (JVM) representation by this function." (setf name (substitute #\/ #\. name)) - (%make-class-name :name-internal name - :ref (concatenate 'string "L" name ";"))) + (%make-jvm-class-name :name-internal name + :ref (concatenate 'string "L" name ";"))) (defun class-array (class-name) "Returns a class-name representing an array of `class-name'. @@ -120,14 +120,14 @@ ;; are identified by the same string (let ((name-and-ref (concatenate 'string "[" (class-ref class-name)))) (setf (class-array-class class-name) - (%make-class-name :name-internal name-and-ref - :ref name-and-ref)))) + (%make-jvm-class-name :name-internal name-and-ref + :ref name-and-ref)))) (class-array-class class-name)) (defmacro define-class-name (symbol java-dotted-name &optional documentation) "Convenience macro to define constants for `class-name' structures, initialized from the `java-dotted-name'." - `(defconstant ,symbol (make-class-name ,java-dotted-name) + `(defconstant ,symbol (make-jvm-class-name ,java-dotted-name) ,documentation)) (define-class-name +java-object+ "java.lang.Object") @@ -835,8 +835,8 @@ (write-attributes (field-attributes field) stream)) -(defstruct (method (:constructor %make-method) - (:conc-name method-)) +(defstruct (jvm-method (:constructor %make-jvm-method) + (:conc-name method-)) "Holds information on the properties of methods in the class(-file)." access-flags name @@ -858,11 +858,11 @@ "") (t name))) -(defun make-method (name return args &key (flags '(:public))) +(defun make-jvm-method (name return args &key (flags '(:public))) "Creates a method for addition to a class file." - (%make-method :descriptor (cons return args) - :access-flags flags - :name (map-method-name name))) + (%make-jvm-method :descriptor (cons return args) + :access-flags flags + :name (map-method-name name))) (defun method-add-attribute (method attribute) "Add `attribute' to the list of attributes of `method', Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/jvm.lisp Thu Nov 25 08:52:51 2010 @@ -137,13 +137,13 @@ (when (or (char= (char name i) #\-) (char= (char name i) #\Space)) (setf (char name i) #\_))) - (make-class-name + (make-jvm-class-name (concatenate 'string "org.armedbear.lisp." name)))) (defun make-unique-class-name () "Creates a random class name for use with a `class-file' structure's `class' slot." - (make-class-name + (make-jvm-class-name (concatenate 'string "abcl_" (substitute #\_ #\- (java:jcall (java:jmethod "java.util.UUID" Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/known-symbols.lisp ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/known-symbols.lisp (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/known-symbols.lisp Thu Nov 25 08:52:51 2010 @@ -38,7 +38,7 @@ (let ((symbols (make-hash-table :test 'eq :size 2048))) (defun initialize-known-symbols (source ht) (let* ((source-class (java:jclass source)) - (class-designator (jvm::make-class-name source)) + (class-designator (jvm::make-jvm-class-name source)) (symbol-class (java:jclass "org.armedbear.lisp.Symbol")) (fields (java:jclass-fields source-class :declared t :public t))) (dotimes (i (length fields)) From ehuelsmann at common-lisp.net Thu Nov 25 14:10:34 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Nov 2010 09:10:34 -0500 Subject: [armedbear-cvs] r13048 - branches/0.23.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 25 09:10:33 2010 New Revision: 13048 Log: Backport DEFUN expansion fixes after loading the precompiler. Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/precompiler.lisp Thu Nov 25 09:10:33 2010 @@ -1159,14 +1159,16 @@ ;; Both COMPILE and COMPILE-FILE bind this variable. ;; This function is also triggered by MACROEXPAND, though jvm::*file-compilation*) - `(fset ',name ,lambda-expression)) + `(progn + (fset ',name ,lambda-expression) + ',name)) (t (when (and env (empty-environment-p env)) (setf env nil)) (when (null env) (setf lambda-expression (precompiler:precompile-form lambda-expression nil))) - `(progn - (%defun ',name ,lambda-expression) + `(prog1 + (%defun ',name ,lambda-expression) ,@(when doc `((%set-documentation ',name 'function ,doc))))))))) From ehuelsmann at common-lisp.net Thu Nov 25 14:12:57 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Nov 2010 09:12:57 -0500 Subject: [armedbear-cvs] r13049 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Nov 25 09:12:56 2010 New Revision: 13049 Log: CHANGES date-update. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Thu Nov 25 09:12:56 2010 @@ -1,7 +1,7 @@ Version 0.23 ============ svn://common-lisp.net/project/armedbear/svn/tags/0.23.0/abcl -(????, 2010) +(25 November, 2010) Features -------- From ehuelsmann at common-lisp.net Thu Nov 25 14:14:05 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Nov 2010 09:14:05 -0500 Subject: [armedbear-cvs] r13050 - branches/0.23.x/abcl Message-ID: Author: ehuelsmann Date: Thu Nov 25 09:14:04 2010 New Revision: 13050 Log: Backport CHANGES. Modified: branches/0.23.x/abcl/CHANGES Modified: branches/0.23.x/abcl/CHANGES ============================================================================== --- branches/0.23.x/abcl/CHANGES (original) +++ branches/0.23.x/abcl/CHANGES Thu Nov 25 09:14:04 2010 @@ -1,7 +1,7 @@ Version 0.23 ============ svn://common-lisp.net/project/armedbear/svn/tags/0.23.0/abcl -(????, 2010) +(25 November, 2010) Features -------- From ehuelsmann at common-lisp.net Thu Nov 25 14:15:21 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Nov 2010 09:15:21 -0500 Subject: [armedbear-cvs] r13051 - in tags/0.23.0: . abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 25 09:15:20 2010 New Revision: 13051 Log: Tag 0.23.0. Added: tags/0.23.0/ - copied from r13050, /branches/0.23.x/ Modified: tags/0.23.0/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.23.0/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.23.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.23.0/abcl/src/org/armedbear/lisp/Version.java Thu Nov 25 09:15:20 2010 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.23.0-dev"; + return "0.23.0"; } public static void main(String args[]) { From ehuelsmann at common-lisp.net Thu Nov 25 14:16:21 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Nov 2010 09:16:21 -0500 Subject: [armedbear-cvs] r13052 - branches/0.23.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Nov 25 09:16:20 2010 New Revision: 13052 Log: Increase 0.23.x patch level version. Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/Version.java Thu Nov 25 09:16:20 2010 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.23.0-dev"; + return "0.23.1-dev"; } public static void main(String args[]) { From ehuelsmann at common-lisp.net Thu Nov 25 15:22:57 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Nov 2010 10:22:57 -0500 Subject: [armedbear-cvs] r13053 - public_html/releases/0.23.0 Message-ID: Author: ehuelsmann Date: Thu Nov 25 10:22:52 2010 New Revision: 13053 Log: Upload 0.23 release. Added: public_html/releases/0.23.0/ public_html/releases/0.23.0/abcl-bin-0.23.0.tar.gz (contents, props changed) public_html/releases/0.23.0/abcl-bin-0.23.0.tar.gz.asc public_html/releases/0.23.0/abcl-bin-0.23.0.zip (contents, props changed) public_html/releases/0.23.0/abcl-bin-0.23.0.zip.asc public_html/releases/0.23.0/abcl-src-0.23.0.tar.gz (contents, props changed) public_html/releases/0.23.0/abcl-src-0.23.0.tar.gz.asc public_html/releases/0.23.0/abcl-src-0.23.0.zip (contents, props changed) public_html/releases/0.23.0/abcl-src-0.23.0.zip.asc Added: public_html/releases/0.23.0/abcl-bin-0.23.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/0.23.0/abcl-bin-0.23.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/0.23.0/abcl-bin-0.23.0.tar.gz.asc Thu Nov 25 10:22:52 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkzuey8ACgkQi5O0Epaz9Tk/ZwCcC9OlNFQI02ycTg27T8KIaIzv +AI8An0NqQp4R5Ep6GwVxgOElbJ4NVGm1 +=n8J/ +-----END PGP SIGNATURE----- Added: public_html/releases/0.23.0/abcl-bin-0.23.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/0.23.0/abcl-bin-0.23.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/0.23.0/abcl-bin-0.23.0.zip.asc Thu Nov 25 10:22:52 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkzue0UACgkQi5O0Epaz9TlwzwCfT3/TyKSic2G1czAMGyD1hZM2 +aVMAn2ZEuhQOYq7dtb8bt8TY/YTIDgTN +=ehgD +-----END PGP SIGNATURE----- Added: public_html/releases/0.23.0/abcl-src-0.23.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/0.23.0/abcl-src-0.23.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/0.23.0/abcl-src-0.23.0.tar.gz.asc Thu Nov 25 10:22:52 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkzue1sACgkQi5O0Epaz9TleOQCeOEXiGxI7g3WzMCZi+JYfLvz8 +MxIAnRJUOx36ybFxy7h152on6xmLNQd0 +=D6b+ +-----END PGP SIGNATURE----- Added: public_html/releases/0.23.0/abcl-src-0.23.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/0.23.0/abcl-src-0.23.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/0.23.0/abcl-src-0.23.0.zip.asc Thu Nov 25 10:22:52 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkzue2QACgkQi5O0Epaz9TlDsQCfejNd/STamF1gdcuNiKWNCVwO +jYwAn2anV53vZ+PtQvQAWXFfHx9oEnda +=omRK +-----END PGP SIGNATURE----- From ehuelsmann at common-lisp.net Thu Nov 25 15:38:05 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Nov 2010 10:38:05 -0500 Subject: [armedbear-cvs] r13054 - public_html Message-ID: Author: ehuelsmann Date: Thu Nov 25 10:38:03 2010 New Revision: 13054 Log: Update website with release data. Modified: public_html/index.shtml public_html/left-menu Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Thu Nov 25 10:38:03 2010 @@ -61,24 +61,24 @@ Binary - abcl-bin-0.22.0.tar.gz - (pgp) + abcl-bin-0.23.0.tar.gz + (pgp) - abcl-bin-0.22.0.zip - (pgp) + abcl-bin-0.23.0.zip + (pgp) Source - abcl-src-0.22.0.tar.gz - (pgp) + abcl-src-0.23.0.tar.gz + (pgp) - abcl-src-0.22.0.zip - (pgp) + abcl-src-0.23.0.zip + (pgp) Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Thu Nov 25 10:38:03 2010 @@ -1,7 +1,7 @@
    Project page
    Testimonials
    -Release notes
    +Release notes
    Paid support
    From mevenson at common-lisp.net Sat Nov 27 11:03:16 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 27 Nov 2010 06:03:16 -0500 Subject: [armedbear-cvs] r13055 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Nov 27 06:03:12 2010 New Revision: 13055 Log: Fix comment typo. Modified: trunk/abcl/src/org/armedbear/lisp/ZipCache.java Modified: trunk/abcl/src/org/armedbear/lisp/ZipCache.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ZipCache.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ZipCache.java Sat Nov 27 06:03:12 2010 @@ -163,7 +163,7 @@ // Sun-derived JVMs. So, we use a custom HEAD // implementation only looking for Last-Modified // headers, which if we don't find, we give up and - // refetch the resource.n + // refetch the resource. String dateString = HttpHead.get(url, "Last-Modified"); Date date = null; ParsePosition pos = new ParsePosition(0); From mevenson at common-lisp.net Sat Nov 27 11:03:35 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 27 Nov 2010 06:03:35 -0500 Subject: [armedbear-cvs] r13056 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Nov 27 06:03:34 2010 New Revision: 13056 Log: Fix problems with #\Space characters in JAR pathnames. We now require that inputs to the PATHNAME routines that have the URI scheme "jar:file" or "file" properly encode themselves as URIs according to RFC2396. Mainly this means that #\Space and #\? characters in such strings should be percent encoded (i.e. "jar:file:/path%20with%20/space/and%3fquestion-mark"). The corresponding namestring routines have been adjusted to output such URI encoded representations, although the underlying PATHNAME objects contain unescaped values. The routines for loading FASLs have been adjusted to URI encode their inputs as well. The #\+ character is no longer an escape for #\Space (this was a bug). Modified: trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/Utilities.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 Nov 27 06:03:34 2010 @@ -153,6 +153,7 @@ if (Utilities.checkZipFile(truename)) { String n = truename.getNamestring(); + n = Pathname.uriEncode(n); if (n.startsWith("jar:")) { n = "jar:" + n + "!/" + truename.name.getStringValue() + "." + COMPILE_FILE_INIT_FASL_TYPE; 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 Nov 27 06:03:34 2010 @@ -38,12 +38,14 @@ import java.io.IOException; import java.io.InputStream; import java.io.FileInputStream; +import java.io.UnsupportedEncodingException; import java.net.MalformedURLException; import java.net.URI; import java.net.URISyntaxException; import java.net.URL; import java.net.URLDecoder; import java.net.URLConnection; +import java.net.URLEncoder; import java.util.Enumeration; import java.util.StringTokenizer; import java.util.zip.ZipEntry; @@ -195,28 +197,10 @@ } public Pathname(URL url) { - if ("file".equals(url.getProtocol())) { - String s = url.getPath(); - if (s != null) { - if (Utilities.isPlatformWindows) { - // Workaround for Java's idea of URLs - // new (URL"file:///c:/a/b").getPath() --> "/c:/a/b" - // whereas we need "c" to be the DEVICE. - if (s.length() > 2 - && s.charAt(0) == '/' - && s.charAt(2) == ':') { - s = s.substring(1); - } - } - init(s); - return; - } - } else { - init(url.toString()); - return; - } - error(new LispError("Failed to construct Pathname from URL: " - + "'" + url.toString() + "'")); + // URL handling is now buried in init(String), as the URI + // escaping mechanism didn't interact well with '+' and other + // characters. + init(url.toString()); } static final Symbol SCHEME = internKeyword("SCHEME"); @@ -279,19 +263,45 @@ jars = jars.push(p.device.car()); } if (jar.startsWith("jar:file:")) { - String jarString - = jar.substring("jar:".length(), + String file + = jar.substring("jar:file:".length(), jar.length() - jarSeparator.length()); - // Use URL constructor to normalize Windows' use of device - URL url = null; - try { - url = new URL(jarString); - } catch (MalformedURLException e) { - error(new LispError("Failed to parse '" + jarString + "'" - + " as URL:" - + e.getMessage())); + Pathname jarPathname; + if (file.length() > 0) { + // Instead of "use URL constructor to normalize Windows' use of device" + // attempt to shorten the URL to pass through the normal constructor. + if (Utilities.isPlatformWindows + && file.charAt(0) == '/' + && file.charAt(2) == ':' + && Character.isLetter(file.charAt(1))) + { + file = file.substring(1); + } + URL url = null; + URI uri = null; + try { + url = new URL("file:" + file); + uri = url.toURI(); + } catch (MalformedURLException e1) { + error(new FileError("Failed to create URI from " + + "'" + file + "'" + + ": " + e1.getMessage())); + } catch (URISyntaxException e2) { + error(new FileError("Failed to create URI from " + + "'" + file + "'" + + ": " + e2.getMessage())); + } + String path = uri.getPath(); + if (path == null) { + // We allow "jar:file:baz.jar!/" to construct a relative + // path for jar files, so MERGE-PATHNAMES means something. + jarPathname = new Pathname(uri.getSchemeSpecificPart()); + } else { + jarPathname = new Pathname(path); + } + } else { + jarPathname = new Pathname(""); } - Pathname jarPathname = new Pathname(url); jars = jars.push(jarPathname); } else { URL url = null; @@ -315,7 +325,15 @@ final int separatorIndex = s.lastIndexOf(jarSeparator); if (separatorIndex > 0 && s.startsWith("jar:")) { final String jarURL = s.substring(0, separatorIndex + jarSeparator.length()); - Pathname d = new Pathname(jarURL); + URL url = null; + try { + url = new URL(jarURL); + } catch (MalformedURLException ex) { + error(new FileError("Failed to parse URL " + + "'" + jarURL + "'" + + ex.getMessage())); + } + Pathname d = new Pathname(url); if (device instanceof Cons) { LispObject[] jars = d.copyToArray(); // XXX Is this ever reached? If so, need to append lists @@ -342,7 +360,15 @@ } String scheme = url.getProtocol(); if (scheme.equals("file")) { - Pathname p = new Pathname(url.getFile()); + URI uri = null; + try { + uri = url.toURI(); + } catch (URISyntaxException ex) { + error(new FileError("Improper URI syntax for " + + "'" + url.toString() + "'" + + ": " + ex.toString())); + } + Pathname p = new Pathname(uri.getPath()); this.host = p.host; this.device = p.device; this.directory = p.directory; @@ -596,6 +622,7 @@ return null; } } + boolean uriEncoded = false; if (device == NIL) { } else if (device == Keyword.UNSPECIFIC) { } else if (isJar()) { @@ -605,8 +632,16 @@ prefix.append("jar:"); if (!((Pathname)jars[i]).isURL() && i == 0) { sb.append("file:"); + uriEncoded = true; + } + Pathname jar = (Pathname) jars[i]; + String encodedNamestring; + if (uriEncoded) { + encodedNamestring = uriEncode(jar.getNamestring()); + } else { + encodedNamestring = jar.getNamestring(); } - sb.append(((Pathname) jars[i]).getNamestring()); + sb.append(encodedNamestring); sb.append("!/"); } sb = prefix.append(sb); @@ -620,6 +655,9 @@ Debug.assertTrue(false); } String directoryNamestring = getDirectoryNamestring(); + if (uriEncoded) { + directoryNamestring = uriEncode(directoryNamestring); + } if (isJar()) { if (directoryNamestring.startsWith("/")) { sb.append(directoryNamestring.substring(1)); @@ -635,7 +673,11 @@ Debug.assertTrue(namestring == null); return null; } - sb.append(n); + if (uriEncoded) { + sb.append(uriEncode(n)); + } else { + sb.append(n); + } } else if (name == Keyword.WILD) { sb.append('*'); } @@ -650,7 +692,11 @@ return null; } } - sb.append(t); + if (uriEncoded) { + sb.append(uriEncode(t)); + } else { + sb.append(t); + } } else if (type == Keyword.WILD) { sb.append('*'); } else { @@ -1981,7 +2027,12 @@ LispObject truename = Pathname.truename((Pathname)o, errorIfDoesNotExist); if (truename != null && truename instanceof Pathname) { - jars.car = (Pathname)truename; + Pathname truePathname = (Pathname)truename; + // A jar that is a directory makes no sense, so exit + if (truePathname.getNamestring().endsWith("/")) { + break jarfile; + } + jars.car = truePathname; } else { break jarfile; } @@ -1994,6 +2045,7 @@ // 2. JAR in JAR // 3. JAR with Entry // 4. JAR in JAR with Entry + ZipFile jarFile = ZipCache.get((Pathname)jars.car()); String entryPath = pathname.asEntryPath(); if (jarFile != null) { @@ -2350,5 +2402,34 @@ Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(coerceToPathname(obj)); } + static String uriDecode(String s) { + try { + URI uri = new URI(null, null, null, s, null); + return uri.toASCIIString().substring(1); + } catch (URISyntaxException e) {} + return null; // Error + } + + static String uriEncode(String s) { + // The constructor we use here only allows absolute paths, so + // we manipulate the input and output correspondingly. + String u; + if (!s.startsWith("/")) { + u = "/" + s; + } else { + u = new String(s); + } + try { + URI uri = new URI("file", "", u, ""); + String result = uri.getRawPath(); + if (!s.startsWith("/")) { + return result.substring(1); + } + return result; + } catch (URISyntaxException e) { + Debug.assertTrue(false); + } + return null; // Error + } } Modified: trunk/abcl/src/org/armedbear/lisp/Utilities.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Utilities.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Utilities.java Sat Nov 27 06:03:34 2010 @@ -254,22 +254,6 @@ return result; } - static String uriEncode(String s) { - try { - URI uri = new URI("?" + s); - return uri.getQuery(); - } catch (URISyntaxException e) {} - return null; - } - - static String uriDecode(String s) { - try { - URI uri = new URI(null, null, null, s, null); - return uri.toASCIIString().substring(1); - } catch (URISyntaxException e) {} - return null; // Error - } - static String escapeFormat(String s) { return s.replace("~", "~~"); } From mevenson at common-lisp.net Sat Nov 27 11:03:59 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 27 Nov 2010 06:03:59 -0500 Subject: [armedbear-cvs] r13057 - in trunk/abcl: . test/lisp/abcl Message-ID: Author: mevenson Date: Sat Nov 27 06:03:58 2010 New Revision: 13057 Log: Tests for the implementation of URI encoding. Restructured test package by factoring commonly used routines into the newly created 'utilities.lisp'. Start marking tests that are known failures. Added: trunk/abcl/test/lisp/abcl/utilities.lisp Modified: trunk/abcl/abcl.asd trunk/abcl/test/lisp/abcl/jar-pathname.lisp trunk/abcl/test/lisp/abcl/pathname-tests.lisp trunk/abcl/test/lisp/abcl/test-utilities.lisp Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Sat Nov 27 06:03:58 2010 @@ -24,17 +24,19 @@ ;;; We guard with #+abcl for tests that other Lisps cannot load. This ;;; could be possibly be done at finer granularity in the files ;;; themselves. -(defsystem :abcl-test-lisp :version "1.1" :components +(defsystem :abcl-test-lisp :version "1.2" :components ((:module abcl-rt :pathname "test/lisp/abcl/" :serial t :components - ((:file "rt-package") (:file "rt") + ((:file "rt-package") + (:file "rt") (:file "test-utilities"))) (:module package :depends-on (abcl-rt) :pathname "test/lisp/abcl/" :components ((:file "package"))) (:module test :depends-on (package) :pathname "test/lisp/abcl/" :components - ((:file "compiler-tests") + ((:file "utilities") + (:file "compiler-tests") (:file "condition-tests") #+abcl (:file "class-file") @@ -47,7 +49,7 @@ (:file "file-system-tests") #+abcl (:file "jar-pathname" :depends-on - ("pathname-tests")) + ("utilities" "pathname-tests" "file-system-tests")) #+abcl (:file "url-pathname") (:file "math-tests") @@ -57,7 +59,7 @@ (:file "bugs" :depends-on ("file-system-tests")) (:file "wild-pathnames" :depends-on ("file-system-tests")) #+abcl - (:file "pathname-tests"))))) + (:file "pathname-tests" :depends-on ("utilities")))))) (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp)))) "Invoke tests with (asdf:oos 'asdf:test-op :abcl-test-lisp)." Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Sat Nov 27 06:03:58 2010 @@ -2,37 +2,6 @@ (defvar *jar-file-init* nil) -;;; From CL-FAD -(defvar *stream-buffer-size* 8192) -(defun cl-fad-copy-stream (from to &optional (checkp t)) - "Copies into TO \(a stream) from FROM \(also a stream) until the end -of FROM is reached, in blocks of *stream-buffer-size*. The streams -should have the same element type. If CHECKP is true, the streams are -checked for compatibility of their types." - (when checkp - (unless (subtypep (stream-element-type to) (stream-element-type from)) - (error "Incompatible streams ~A and ~A." from to))) - (let ((buf (make-array *stream-buffer-size* - :element-type (stream-element-type from)))) - (loop - (let ((pos (read-sequence buf from))) - (when (zerop pos) (return)) - (write-sequence buf to :end pos)))) - (values)) - -(defun cl-fad-copy-file (from to &key overwrite) - "Copies the file designated by the non-wild pathname designator FROM -to the file designated by the non-wild pathname designator TO. If -OVERWRITE is true overwrites the file designtated by TO if it exists." - (let ((element-type '(unsigned-byte 8))) - (with-open-file (in from :element-type element-type) - (with-open-file (out to :element-type element-type - :direction :output - :if-exists (if overwrite - :supersede :error)) - (cl-fad-copy-stream in out)))) - (values)) - (defun jar-file-init () (let* ((*default-pathname-defaults* *abcl-test-directory*) (asdf::*verbose-out* *standard-output*)) @@ -197,12 +166,14 @@ #p#.(format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._" (namestring *abcl-test-directory*))) +(push 'jar-pathname.probe-file.4 *expected-failures*) (deftest jar-pathname.probe-file.4 (with-jar-file-init (probe-file "jar:file:baz.jar!/a/b")) #p#.(format nil "jar:file:~Abaz.jar!/a/b/" (namestring *abcl-test-directory*))) +(push 'jar-pathname.probe-file.5 *expected-failures*) (deftest jar-pathname.probe-file.5 (with-jar-file-init (probe-file "jar:file:baz.jar!/a/b/")) @@ -341,18 +312,27 @@ (:relative "a" "b") "foo" "jar" (:absolute "c" "d") "foo" "lisp") +;;; 'jar:file:' forms must be URI encoded, meaning whitespace is not allowed (deftest jar-pathname.10 - (let ((s "jar:file:/foo/bar/a space/that!/this")) - (equal s - (namestring (pathname s)))) + (signals-error + (let ((s "jar:file:/foo/bar/a space/that!/this")) + (equal s + (namestring (pathname s)))) + 'file-error) t) (deftest jar-pathname.11 - (let ((s "jar:file:/foo/bar/a+space/that!/this")) - (equal s + (let ((s "jar:file:/foo/bar/a%20space%3f/that!/this")) + (string= s (namestring (pathname s)))) t) +;;; We allow jar-pathname to be contructed without a device to allow +;;; MERGE-PATHNAMES to work, even though #p"file:" is illegal. +(deftest jar-pathname.12 + (string= (namestring (first (pathname-device #p"jar:file:!/foo.bar"))) + "") + t) (deftest jar-pathname.match-p.1 (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd" Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/pathname-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/pathname-tests.lisp Sat Nov 27 06:03:58 2010 @@ -1681,3 +1681,35 @@ (type-error () t)) t) +(deftest pathname.uri-encoding.1 + (signals-error + (let ((s "file:/path with /spaces")) + (equal s + (namestring (pathname s)))) + 'file-error) + t) + +(deftest pathname.uri-encoding.2 + (equal "/path with/uri-escaped/?characters/" + (namestring (pathname "file:/path%20with/uri-escaped/%3fcharacters/"))) + t) + +(deftest pathname.load.1 + (let ((dir (merge-pathnames "dir+with+plus/" + *abcl-test-directory*))) + (with-temp-directory (dir) + (let ((file (merge-pathnames "foo.lisp" dir))) + (with-open-file (s file :direction :output) + (write *foo.lisp* :stream s)) + (load file)))) + t) + +(deftest pathname.load.2 + (let ((dir (merge-pathnames "dir with space/" + *abcl-test-directory*))) + (with-temp-directory (dir) + (let ((file (merge-pathnames "foo.lisp" dir))) + (with-open-file (s file :direction :output) + (write *foo.lisp* :stream s)) + (load file)))) + t) Modified: trunk/abcl/test/lisp/abcl/test-utilities.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/test-utilities.lisp (original) +++ trunk/abcl/test/lisp/abcl/test-utilities.lisp Sat Nov 27 06:03:58 2010 @@ -36,3 +36,4 @@ #+nil (rem-all-tests) #+nil (setf *expected-failures* nil) + Added: trunk/abcl/test/lisp/abcl/utilities.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/utilities.lisp Sat Nov 27 06:03:58 2010 @@ -0,0 +1,45 @@ +(in-package #:abcl.test.lisp) +;;; From CL-FAD +(defvar *stream-buffer-size* 8192) +(defun cl-fad-copy-stream (from to &optional (checkp t)) + "Copies into TO \(a stream) from FROM \(also a stream) until the end +of FROM is reached, in blocks of *stream-buffer-size*. The streams +should have the same element type. If CHECKP is true, the streams are +checked for compatibility of their types." + (when checkp + (unless (subtypep (stream-element-type to) (stream-element-type from)) + (error "Incompatible streams ~A and ~A." from to))) + (let ((buf (make-array *stream-buffer-size* + :element-type (stream-element-type from)))) + (loop + (let ((pos (read-sequence buf from))) + (when (zerop pos) (return)) + (write-sequence buf to :end pos)))) + (values)) + +(defun cl-fad-copy-file (from to &key overwrite) + "Copies the file designated by the non-wild pathname designator FROM +to the file designated by the non-wild pathname designator TO. If +OVERWRITE is true overwrites the file designtated by TO if it exists." + (let ((element-type '(unsigned-byte 8))) + (with-open-file (in from :element-type element-type) + (with-open-file (out to :element-type element-type + :direction :output + :if-exists (if overwrite + :supersede :error)) + (cl-fad-copy-stream in out)))) + (values)) + +(defvar *foo.lisp* + `(defun foo () + (labels ((output () + (format t "FOO here."))) + (output)))) + +(defmacro with-temp-directory ((directory) &rest body) + `(let ((*default-pathname-defaults* *abcl-test-directory*)) + (ensure-directories-exist ,directory) + (prog1 + , at body + (delete-directory-and-files ,directory)))) + From mevenson at common-lisp.net Sat Nov 27 11:04:26 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 27 Nov 2010 06:04:26 -0500 Subject: [armedbear-cvs] r13058 - trunk/abcl/doc/design/pathnames Message-ID: Author: mevenson Date: Sat Nov 27 06:04:25 2010 New Revision: 13058 Log: Documentation for the URI encoding changes. Modified: trunk/abcl/doc/design/pathnames/jar-pathnames.markdown trunk/abcl/doc/design/pathnames/url-pathnames.markdown Modified: trunk/abcl/doc/design/pathnames/jar-pathnames.markdown ============================================================================== --- trunk/abcl/doc/design/pathnames/jar-pathnames.markdown (original) +++ trunk/abcl/doc/design/pathnames/jar-pathnames.markdown Sat Nov 27 06:04:25 2010 @@ -3,7 +3,7 @@ Mark Evenson Created: 09 JAN 2010 - Modified: 10 APR 2010 + Modified: 26 NOV 2010 Notes towards an implementation of "jar:" references to be contained in Common Lisp `PATHNAME`s within ABCL. @@ -12,7 +12,6 @@ ----- 1. Use Common Lisp pathnames to refer to entries in a jar file. - 2. Use `'jar:'` schema as documented in [`java.net.JarURLConnection`][jarURLConnection] for namestring representation. @@ -66,8 +65,7 @@ Status ------ -As of svn r125??, all the above goals have been implemented and -tested. +All the above goals have been implemented and tested. Implementation @@ -92,7 +90,8 @@ Otherwise the the DEVICE PATHAME denotes the PATHNAME of the JAR file. The DEVICE PATHNAME list of enclosing JARs runs from outermost to -innermost. +innermost. The implementaion currently limits this list to have at +most two elements. The DIRECTORY component of a JAR PATHNAME should be a list starting with the :ABSOLUTE keyword. Even though hierarchial entries in jar @@ -123,10 +122,11 @@ ### Notes -1. `ABSOLUTE-FILE-NAMESTRING` and `RELATIVE-FILE-NAMESTRING` use the -local filesystem conventions, meaning that on Windows this could -contain '\' as the directory separator, while an `ENTRY` always uses '/' -to separate directories within the jar proper. +1. `ABSOLUTE-FILE-NAMESTRING` and `RELATIVE-FILE-NAMESTRING` can use +the local filesystem conventions, meaning that on Windows this could +contain '\' as the directory separator, which are always normalized to +'/'. An `ENTRY` always uses '/' to separate directories within the +jar archive. Use Cases Modified: trunk/abcl/doc/design/pathnames/url-pathnames.markdown ============================================================================== --- trunk/abcl/doc/design/pathnames/url-pathnames.markdown (original) +++ trunk/abcl/doc/design/pathnames/url-pathnames.markdown Sat Nov 27 06:04:25 2010 @@ -3,7 +3,7 @@ Mark Evenson Created: 25 MAR 2010 - Modified: 11 APR 2010 + Modified: 26 NOV 2010 Notes towards an implementation of URL references to be contained in Common Lisp `PATHNAME` objects within ABCL. @@ -18,10 +18,10 @@ URL vs URI ---------- -We use the term URL to describe the URL Pathnames, even though RFC3986 -notes that its use should be obsolete because in the context of Common -Lisp Pathnames all need a lookup mechanism to be resolved or they -wouldn't be of much use. +We use the term URL as shorthand in describing the URL Pathnames, even +though the corresponding encoding is more akin to a URI as described +in RFC3986. + Goals ----- @@ -34,7 +34,7 @@ 3. Use URL schemes that are understood by the java.net.URL object. - A file specified by URL + Example of a Pathname specified by URL: #p"http://example.org/org/armedbear/systems/pgp.asd" @@ -49,17 +49,20 @@ 6. TRUENAME "aliased" to PROBE-FILE signalling an error if the URL is not accessible (see "Non-goal 1"). -7. DIRECTORY for non-wildcards +7. DIRECTORY works for non-wildcards. 8. URL pathname work as a valid argument for OPEN with :DIRECTION :INPUT. 9. Enable the loading of ASDF2 systems referenced by a URL pathname. -10. The reserved URL characters (`~`, `/`, `?`, etc.) shall be -encoded in the proper manner on construction of the Pathname. +10. Pathnames constructed with the "file" scheme +(i.e. #p"file:/this/file") need to be properly URI encoded according +to RFC3986 or otherwise will signal FILE-ERROR. 11. The "file" scheme will continue to be represented by an -"ordinary" Pathname. +"ordinary" Pathname. Thus, after construction of a URL Pathname with +the "file" scheme, the namestring of the resulting PATHNAME will no +longer contain the "file:" prefix. 12. The "jar" scheme will continue to be represented by a jar Pathname. @@ -68,10 +71,10 @@ Non-goals --------- -1. We will not implement canonicalization of URL schemas (such as following -"http" redirects). +1. We will not implement canonicalization of URL schemas (such as +following "http" redirects). -2. DIRECTORY working for URL pathnames containing wildcards. +2. DIRECTORY will not work for URL pathnames containing wildcards. Implementation @@ -119,4 +122,11 @@ Status ------ -This design is a proposal. +This design has been implemented. + +History +------- + +26 NOV 2010 Changed implemenation to use URI encodings for the "file" + schemes including those nested with the "jar" scheme by like + aka. "jar:file:/location/of/some.jar!/". From vvoutilainen at common-lisp.net Sat Nov 27 21:08:29 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 27 Nov 2010 16:08:29 -0500 Subject: [armedbear-cvs] r13059 - trunk/abcl/src/org/armedbear/lisp/scripting Message-ID: Author: vvoutilainen Date: Sat Nov 27 16:08:26 2010 New Revision: 13059 Log: Delay the instantiation of the script engine until it's actually requested. This will allow jsr-223 clients to query for the engine metadata without instantiating the engine. Reported by Martin Hepperle. Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Sat Nov 27 16:08:26 2010 @@ -29,7 +29,7 @@ public class AbclScriptEngineFactory implements ScriptEngineFactory { - private static final AbclScriptEngine THE_ONLY_ONE_ENGINE = new AbclScriptEngine(); + private static AbclScriptEngine THE_ONLY_ONE_ENGINE = null; public String getEngineName() { return "ABCL Script"; @@ -116,6 +116,9 @@ } public ScriptEngine getScriptEngine() { + if (THE_ONLY_ONE_ENGINE == null) { + THE_ONLY_ONE_ENGINE = new AbclScriptEngine(); + } return THE_ONLY_ONE_ENGINE; } From vvoutilainen at common-lisp.net Sat Nov 27 21:21:16 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 27 Nov 2010 16:21:16 -0500 Subject: [armedbear-cvs] r13060 - trunk/abcl/src/org/armedbear/lisp/scripting Message-ID: Author: vvoutilainen Date: Sat Nov 27 16:21:16 2010 New Revision: 13060 Log: Make the getter for the engine synchronized, as the engine is nowadays lazy-initialized. Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Sat Nov 27 16:21:16 2010 @@ -115,7 +115,7 @@ return sb.toString(); } - public ScriptEngine getScriptEngine() { + public synchronized ScriptEngine getScriptEngine() { if (THE_ONLY_ONE_ENGINE == null) { THE_ONLY_ONE_ENGINE = new AbclScriptEngine(); } From vvoutilainen at common-lisp.net Sat Nov 27 21:25:04 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 27 Nov 2010 16:25:04 -0500 Subject: [armedbear-cvs] r13061 - branches/0.23.x/abcl/src/org/armedbear/lisp/scripting Message-ID: Author: vvoutilainen Date: Sat Nov 27 16:25:03 2010 New Revision: 13061 Log: Backport r13059 and r13060 from trunk. Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Sat Nov 27 16:25:03 2010 @@ -29,7 +29,7 @@ public class AbclScriptEngineFactory implements ScriptEngineFactory { - private static final AbclScriptEngine THE_ONLY_ONE_ENGINE = new AbclScriptEngine(); + private static AbclScriptEngine THE_ONLY_ONE_ENGINE = null; public String getEngineName() { return "ABCL Script"; @@ -115,7 +115,10 @@ return sb.toString(); } - public ScriptEngine getScriptEngine() { + public synchronized ScriptEngine getScriptEngine() { + if (THE_ONLY_ONE_ENGINE == null) { + THE_ONLY_ONE_ENGINE = new AbclScriptEngine(); + } return THE_ONLY_ONE_ENGINE; } From ehuelsmann at common-lisp.net Sun Nov 28 13:56:58 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 28 Nov 2010 08:56:58 -0500 Subject: [armedbear-cvs] r13062 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sun Nov 28 08:56:57 2010 New Revision: 13062 Log: Add eol-style properties. Modified: trunk/abcl/test/lisp/abcl/mop-tests-setup.lisp (props changed) trunk/abcl/test/lisp/abcl/mop-tests.lisp (props changed) From ehuelsmann at common-lisp.net Sun Nov 28 14:02:17 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 28 Nov 2010 09:02:17 -0500 Subject: [armedbear-cvs] r13063 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Nov 28 09:02:16 2010 New Revision: 13063 Log: Change back to older code until I figure out how to use the interpreter and initialized field members in the way I intended. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Sun Nov 28 09:02:16 2010 @@ -126,7 +126,7 @@ } public static boolean initialized() { - return interpreter != null; + return initialized; } private Interpreter() From ehuelsmann at common-lisp.net Sun Nov 28 21:35:30 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 28 Nov 2010 16:35:30 -0500 Subject: [armedbear-cvs] r13064 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Nov 28 16:35:27 2010 New Revision: 13064 Log: Increase FASL version number: r13021 put the responsibility of restoring special bindings on the receiving end of non-local control transfers (instead of on *all* intermediate levels). Modified: trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sun Nov 28 16:35:27 2010 @@ -343,7 +343,7 @@ // ### *fasl-version* // internal symbol static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(36)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(37)); // ### *fasl-external-format* // internal symbol From ehuelsmann at common-lisp.net Sun Nov 28 21:47:46 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 28 Nov 2010 16:47:46 -0500 Subject: [armedbear-cvs] r13021 - svn:log Message-ID: Author: ehuelsmann Revision: 13021 Property Name: svn:log Action: added Property value: Reduce the number of ATHROW instructions executed while running the Maxima test suite by ~60%. Note: because we don't generate stack dumps on our ControlTransfer exception derivatives, we only save 2% execution time. [Note from the future: this commit requires a FASL version number update which got committed at r13064.] From mevenson at common-lisp.net Mon Nov 29 08:51:05 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 29 Nov 2010 03:51:05 -0500 Subject: [armedbear-cvs] r13065 - branches/0.23.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Nov 29 03:51:04 2010 New Revision: 13065 Log: [backport r13056] Fix problems with #\Space characters in JAR pathnames. Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/Load.java branches/0.23.x/abcl/src/org/armedbear/lisp/Pathname.java branches/0.23.x/abcl/src/org/armedbear/lisp/Utilities.java Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/Load.java (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/Load.java Mon Nov 29 03:51:04 2010 @@ -153,6 +153,7 @@ if (Utilities.checkZipFile(truename)) { String n = truename.getNamestring(); + n = Pathname.uriEncode(n); if (n.startsWith("jar:")) { n = "jar:" + n + "!/" + truename.name.getStringValue() + "." + COMPILE_FILE_INIT_FASL_TYPE; Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/Pathname.java Mon Nov 29 03:51:04 2010 @@ -38,12 +38,14 @@ import java.io.IOException; import java.io.InputStream; import java.io.FileInputStream; +import java.io.UnsupportedEncodingException; import java.net.MalformedURLException; import java.net.URI; import java.net.URISyntaxException; import java.net.URL; import java.net.URLDecoder; import java.net.URLConnection; +import java.net.URLEncoder; import java.util.Enumeration; import java.util.StringTokenizer; import java.util.zip.ZipEntry; @@ -195,28 +197,10 @@ } public Pathname(URL url) { - if ("file".equals(url.getProtocol())) { - String s = url.getPath(); - if (s != null) { - if (Utilities.isPlatformWindows) { - // Workaround for Java's idea of URLs - // new (URL"file:///c:/a/b").getPath() --> "/c:/a/b" - // whereas we need "c" to be the DEVICE. - if (s.length() > 2 - && s.charAt(0) == '/' - && s.charAt(2) == ':') { - s = s.substring(1); - } - } - init(s); - return; - } - } else { - init(url.toString()); - return; - } - error(new LispError("Failed to construct Pathname from URL: " - + "'" + url.toString() + "'")); + // URL handling is now buried in init(String), as the URI + // escaping mechanism didn't interact well with '+' and other + // characters. + init(url.toString()); } static final Symbol SCHEME = internKeyword("SCHEME"); @@ -279,19 +263,45 @@ jars = jars.push(p.device.car()); } if (jar.startsWith("jar:file:")) { - String jarString - = jar.substring("jar:".length(), + String file + = jar.substring("jar:file:".length(), jar.length() - jarSeparator.length()); - // Use URL constructor to normalize Windows' use of device - URL url = null; - try { - url = new URL(jarString); - } catch (MalformedURLException e) { - error(new LispError("Failed to parse '" + jarString + "'" - + " as URL:" - + e.getMessage())); + Pathname jarPathname; + if (file.length() > 0) { + // Instead of "use URL constructor to normalize Windows' use of device" + // attempt to shorten the URL to pass through the normal constructor. + if (Utilities.isPlatformWindows + && file.charAt(0) == '/' + && file.charAt(2) == ':' + && Character.isLetter(file.charAt(1))) + { + file = file.substring(1); + } + URL url = null; + URI uri = null; + try { + url = new URL("file:" + file); + uri = url.toURI(); + } catch (MalformedURLException e1) { + error(new FileError("Failed to create URI from " + + "'" + file + "'" + + ": " + e1.getMessage())); + } catch (URISyntaxException e2) { + error(new FileError("Failed to create URI from " + + "'" + file + "'" + + ": " + e2.getMessage())); + } + String path = uri.getPath(); + if (path == null) { + // We allow "jar:file:baz.jar!/" to construct a relative + // path for jar files, so MERGE-PATHNAMES means something. + jarPathname = new Pathname(uri.getSchemeSpecificPart()); + } else { + jarPathname = new Pathname(path); + } + } else { + jarPathname = new Pathname(""); } - Pathname jarPathname = new Pathname(url); jars = jars.push(jarPathname); } else { URL url = null; @@ -315,7 +325,15 @@ final int separatorIndex = s.lastIndexOf(jarSeparator); if (separatorIndex > 0 && s.startsWith("jar:")) { final String jarURL = s.substring(0, separatorIndex + jarSeparator.length()); - Pathname d = new Pathname(jarURL); + URL url = null; + try { + url = new URL(jarURL); + } catch (MalformedURLException ex) { + error(new FileError("Failed to parse URL " + + "'" + jarURL + "'" + + ex.getMessage())); + } + Pathname d = new Pathname(url); if (device instanceof Cons) { LispObject[] jars = d.copyToArray(); // XXX Is this ever reached? If so, need to append lists @@ -342,7 +360,15 @@ } String scheme = url.getProtocol(); if (scheme.equals("file")) { - Pathname p = new Pathname(url.getFile()); + URI uri = null; + try { + uri = url.toURI(); + } catch (URISyntaxException ex) { + error(new FileError("Improper URI syntax for " + + "'" + url.toString() + "'" + + ": " + ex.toString())); + } + Pathname p = new Pathname(uri.getPath()); this.host = p.host; this.device = p.device; this.directory = p.directory; @@ -596,6 +622,7 @@ return null; } } + boolean uriEncoded = false; if (device == NIL) { } else if (device == Keyword.UNSPECIFIC) { } else if (isJar()) { @@ -605,8 +632,16 @@ prefix.append("jar:"); if (!((Pathname)jars[i]).isURL() && i == 0) { sb.append("file:"); + uriEncoded = true; + } + Pathname jar = (Pathname) jars[i]; + String encodedNamestring; + if (uriEncoded) { + encodedNamestring = uriEncode(jar.getNamestring()); + } else { + encodedNamestring = jar.getNamestring(); } - sb.append(((Pathname) jars[i]).getNamestring()); + sb.append(encodedNamestring); sb.append("!/"); } sb = prefix.append(sb); @@ -620,6 +655,9 @@ Debug.assertTrue(false); } String directoryNamestring = getDirectoryNamestring(); + if (uriEncoded) { + directoryNamestring = uriEncode(directoryNamestring); + } if (isJar()) { if (directoryNamestring.startsWith("/")) { sb.append(directoryNamestring.substring(1)); @@ -635,7 +673,11 @@ Debug.assertTrue(namestring == null); return null; } - sb.append(n); + if (uriEncoded) { + sb.append(uriEncode(n)); + } else { + sb.append(n); + } } else if (name == Keyword.WILD) { sb.append('*'); } @@ -650,7 +692,11 @@ return null; } } - sb.append(t); + if (uriEncoded) { + sb.append(uriEncode(t)); + } else { + sb.append(t); + } } else if (type == Keyword.WILD) { sb.append('*'); } else { @@ -1970,7 +2016,12 @@ LispObject truename = Pathname.truename((Pathname)o, errorIfDoesNotExist); if (truename != null && truename instanceof Pathname) { - jars.car = (Pathname)truename; + Pathname truePathname = (Pathname)truename; + // A jar that is a directory makes no sense, so exit + if (truePathname.getNamestring().endsWith("/")) { + break jarfile; + } + jars.car = truePathname; } else { break jarfile; } @@ -1983,6 +2034,7 @@ // 2. JAR in JAR // 3. JAR with Entry // 4. JAR in JAR with Entry + ZipFile jarFile = ZipCache.get((Pathname)jars.car()); String entryPath = pathname.asEntryPath(); if (jarFile != null) { @@ -2339,5 +2391,34 @@ Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(coerceToPathname(obj)); } + static String uriDecode(String s) { + try { + URI uri = new URI(null, null, null, s, null); + return uri.toASCIIString().substring(1); + } catch (URISyntaxException e) {} + return null; // Error + } + + static String uriEncode(String s) { + // The constructor we use here only allows absolute paths, so + // we manipulate the input and output correspondingly. + String u; + if (!s.startsWith("/")) { + u = "/" + s; + } else { + u = new String(s); + } + try { + URI uri = new URI("file", "", u, ""); + String result = uri.getRawPath(); + if (!s.startsWith("/")) { + return result.substring(1); + } + return result; + } catch (URISyntaxException e) { + Debug.assertTrue(false); + } + return null; // Error + } } Modified: branches/0.23.x/abcl/src/org/armedbear/lisp/Utilities.java ============================================================================== --- branches/0.23.x/abcl/src/org/armedbear/lisp/Utilities.java (original) +++ branches/0.23.x/abcl/src/org/armedbear/lisp/Utilities.java Mon Nov 29 03:51:04 2010 @@ -254,22 +254,6 @@ return result; } - static String uriEncode(String s) { - try { - URI uri = new URI("?" + s); - return uri.getQuery(); - } catch (URISyntaxException e) {} - return null; - } - - static String uriDecode(String s) { - try { - URI uri = new URI(null, null, null, s, null); - return uri.toASCIIString().substring(1); - } catch (URISyntaxException e) {} - return null; // Error - } - static String escapeFormat(String s) { return s.replace("~", "~~"); } From mevenson at common-lisp.net Mon Nov 29 08:52:06 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 29 Nov 2010 03:52:06 -0500 Subject: [armedbear-cvs] r13066 - in branches/0.23.x/abcl: . test/lisp/abcl Message-ID: Author: mevenson Date: Mon Nov 29 03:52:05 2010 New Revision: 13066 Log: [backport r13057] Tests for the implementation of URI encoding. Added: branches/0.23.x/abcl/test/lisp/abcl/utilities.lisp - copied unchanged from r13057, /trunk/abcl/test/lisp/abcl/utilities.lisp Modified: branches/0.23.x/abcl/abcl.asd branches/0.23.x/abcl/test/lisp/abcl/jar-pathname.lisp branches/0.23.x/abcl/test/lisp/abcl/pathname-tests.lisp branches/0.23.x/abcl/test/lisp/abcl/test-utilities.lisp Modified: branches/0.23.x/abcl/abcl.asd ============================================================================== --- branches/0.23.x/abcl/abcl.asd (original) +++ branches/0.23.x/abcl/abcl.asd Mon Nov 29 03:52:05 2010 @@ -24,17 +24,19 @@ ;;; We guard with #+abcl for tests that other Lisps cannot load. This ;;; could be possibly be done at finer granularity in the files ;;; themselves. -(defsystem :abcl-test-lisp :version "1.1" :components +(defsystem :abcl-test-lisp :version "1.2" :components ((:module abcl-rt :pathname "test/lisp/abcl/" :serial t :components - ((:file "rt-package") (:file "rt") + ((:file "rt-package") + (:file "rt") (:file "test-utilities"))) (:module package :depends-on (abcl-rt) :pathname "test/lisp/abcl/" :components ((:file "package"))) (:module test :depends-on (package) :pathname "test/lisp/abcl/" :components - ((:file "compiler-tests") + ((:file "utilities") + (:file "compiler-tests") (:file "condition-tests") #+abcl (:file "class-file") @@ -47,7 +49,7 @@ (:file "file-system-tests") #+abcl (:file "jar-pathname" :depends-on - ("pathname-tests")) + ("utilities" "pathname-tests" "file-system-tests")) #+abcl (:file "url-pathname") (:file "math-tests") @@ -57,7 +59,7 @@ (:file "bugs" :depends-on ("file-system-tests")) (:file "wild-pathnames" :depends-on ("file-system-tests")) #+abcl - (:file "pathname-tests"))))) + (:file "pathname-tests" :depends-on ("utilities")))))) (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp)))) "Invoke tests with (asdf:oos 'asdf:test-op :abcl-test-lisp)." Modified: branches/0.23.x/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- branches/0.23.x/abcl/test/lisp/abcl/jar-pathname.lisp (original) +++ branches/0.23.x/abcl/test/lisp/abcl/jar-pathname.lisp Mon Nov 29 03:52:05 2010 @@ -2,37 +2,6 @@ (defvar *jar-file-init* nil) -;;; From CL-FAD -(defvar *stream-buffer-size* 8192) -(defun cl-fad-copy-stream (from to &optional (checkp t)) - "Copies into TO \(a stream) from FROM \(also a stream) until the end -of FROM is reached, in blocks of *stream-buffer-size*. The streams -should have the same element type. If CHECKP is true, the streams are -checked for compatibility of their types." - (when checkp - (unless (subtypep (stream-element-type to) (stream-element-type from)) - (error "Incompatible streams ~A and ~A." from to))) - (let ((buf (make-array *stream-buffer-size* - :element-type (stream-element-type from)))) - (loop - (let ((pos (read-sequence buf from))) - (when (zerop pos) (return)) - (write-sequence buf to :end pos)))) - (values)) - -(defun cl-fad-copy-file (from to &key overwrite) - "Copies the file designated by the non-wild pathname designator FROM -to the file designated by the non-wild pathname designator TO. If -OVERWRITE is true overwrites the file designtated by TO if it exists." - (let ((element-type '(unsigned-byte 8))) - (with-open-file (in from :element-type element-type) - (with-open-file (out to :element-type element-type - :direction :output - :if-exists (if overwrite - :supersede :error)) - (cl-fad-copy-stream in out)))) - (values)) - (defun jar-file-init () (let* ((*default-pathname-defaults* *abcl-test-directory*) (asdf::*verbose-out* *standard-output*)) @@ -197,12 +166,14 @@ #p#.(format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._" (namestring *abcl-test-directory*))) +(push 'jar-pathname.probe-file.4 *expected-failures*) (deftest jar-pathname.probe-file.4 (with-jar-file-init (probe-file "jar:file:baz.jar!/a/b")) #p#.(format nil "jar:file:~Abaz.jar!/a/b/" (namestring *abcl-test-directory*))) +(push 'jar-pathname.probe-file.5 *expected-failures*) (deftest jar-pathname.probe-file.5 (with-jar-file-init (probe-file "jar:file:baz.jar!/a/b/")) @@ -341,18 +312,27 @@ (:relative "a" "b") "foo" "jar" (:absolute "c" "d") "foo" "lisp") +;;; 'jar:file:' forms must be URI encoded, meaning whitespace is not allowed (deftest jar-pathname.10 - (let ((s "jar:file:/foo/bar/a space/that!/this")) - (equal s - (namestring (pathname s)))) + (signals-error + (let ((s "jar:file:/foo/bar/a space/that!/this")) + (equal s + (namestring (pathname s)))) + 'file-error) t) (deftest jar-pathname.11 - (let ((s "jar:file:/foo/bar/a+space/that!/this")) - (equal s + (let ((s "jar:file:/foo/bar/a%20space%3f/that!/this")) + (string= s (namestring (pathname s)))) t) +;;; We allow jar-pathname to be contructed without a device to allow +;;; MERGE-PATHNAMES to work, even though #p"file:" is illegal. +(deftest jar-pathname.12 + (string= (namestring (first (pathname-device #p"jar:file:!/foo.bar"))) + "") + t) (deftest jar-pathname.match-p.1 (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd" Modified: branches/0.23.x/abcl/test/lisp/abcl/pathname-tests.lisp ============================================================================== --- branches/0.23.x/abcl/test/lisp/abcl/pathname-tests.lisp (original) +++ branches/0.23.x/abcl/test/lisp/abcl/pathname-tests.lisp Mon Nov 29 03:52:05 2010 @@ -1681,3 +1681,35 @@ (type-error () t)) t) +(deftest pathname.uri-encoding.1 + (signals-error + (let ((s "file:/path with /spaces")) + (equal s + (namestring (pathname s)))) + 'file-error) + t) + +(deftest pathname.uri-encoding.2 + (equal "/path with/uri-escaped/?characters/" + (namestring (pathname "file:/path%20with/uri-escaped/%3fcharacters/"))) + t) + +(deftest pathname.load.1 + (let ((dir (merge-pathnames "dir+with+plus/" + *abcl-test-directory*))) + (with-temp-directory (dir) + (let ((file (merge-pathnames "foo.lisp" dir))) + (with-open-file (s file :direction :output) + (write *foo.lisp* :stream s)) + (load file)))) + t) + +(deftest pathname.load.2 + (let ((dir (merge-pathnames "dir with space/" + *abcl-test-directory*))) + (with-temp-directory (dir) + (let ((file (merge-pathnames "foo.lisp" dir))) + (with-open-file (s file :direction :output) + (write *foo.lisp* :stream s)) + (load file)))) + t) Modified: branches/0.23.x/abcl/test/lisp/abcl/test-utilities.lisp ============================================================================== --- branches/0.23.x/abcl/test/lisp/abcl/test-utilities.lisp (original) +++ branches/0.23.x/abcl/test/lisp/abcl/test-utilities.lisp Mon Nov 29 03:52:05 2010 @@ -36,3 +36,4 @@ #+nil (rem-all-tests) #+nil (setf *expected-failures* nil) + From mevenson at common-lisp.net Mon Nov 29 08:52:59 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 29 Nov 2010 03:52:59 -0500 Subject: [armedbear-cvs] r13067 - branches/0.23.x/abcl/doc/design/pathnames Message-ID: Author: mevenson Date: Mon Nov 29 03:52:58 2010 New Revision: 13067 Log: [backport r13058] Documentation for the URI encoding changes. Modified: branches/0.23.x/abcl/doc/design/pathnames/jar-pathnames.markdown branches/0.23.x/abcl/doc/design/pathnames/url-pathnames.markdown Modified: branches/0.23.x/abcl/doc/design/pathnames/jar-pathnames.markdown ============================================================================== --- branches/0.23.x/abcl/doc/design/pathnames/jar-pathnames.markdown (original) +++ branches/0.23.x/abcl/doc/design/pathnames/jar-pathnames.markdown Mon Nov 29 03:52:58 2010 @@ -3,7 +3,7 @@ Mark Evenson Created: 09 JAN 2010 - Modified: 10 APR 2010 + Modified: 26 NOV 2010 Notes towards an implementation of "jar:" references to be contained in Common Lisp `PATHNAME`s within ABCL. @@ -12,7 +12,6 @@ ----- 1. Use Common Lisp pathnames to refer to entries in a jar file. - 2. Use `'jar:'` schema as documented in [`java.net.JarURLConnection`][jarURLConnection] for namestring representation. @@ -66,8 +65,7 @@ Status ------ -As of svn r125??, all the above goals have been implemented and -tested. +All the above goals have been implemented and tested. Implementation @@ -92,7 +90,8 @@ Otherwise the the DEVICE PATHAME denotes the PATHNAME of the JAR file. The DEVICE PATHNAME list of enclosing JARs runs from outermost to -innermost. +innermost. The implementaion currently limits this list to have at +most two elements. The DIRECTORY component of a JAR PATHNAME should be a list starting with the :ABSOLUTE keyword. Even though hierarchial entries in jar @@ -123,10 +122,11 @@ ### Notes -1. `ABSOLUTE-FILE-NAMESTRING` and `RELATIVE-FILE-NAMESTRING` use the -local filesystem conventions, meaning that on Windows this could -contain '\' as the directory separator, while an `ENTRY` always uses '/' -to separate directories within the jar proper. +1. `ABSOLUTE-FILE-NAMESTRING` and `RELATIVE-FILE-NAMESTRING` can use +the local filesystem conventions, meaning that on Windows this could +contain '\' as the directory separator, which are always normalized to +'/'. An `ENTRY` always uses '/' to separate directories within the +jar archive. Use Cases Modified: branches/0.23.x/abcl/doc/design/pathnames/url-pathnames.markdown ============================================================================== --- branches/0.23.x/abcl/doc/design/pathnames/url-pathnames.markdown (original) +++ branches/0.23.x/abcl/doc/design/pathnames/url-pathnames.markdown Mon Nov 29 03:52:58 2010 @@ -3,7 +3,7 @@ Mark Evenson Created: 25 MAR 2010 - Modified: 11 APR 2010 + Modified: 26 NOV 2010 Notes towards an implementation of URL references to be contained in Common Lisp `PATHNAME` objects within ABCL. @@ -18,10 +18,10 @@ URL vs URI ---------- -We use the term URL to describe the URL Pathnames, even though RFC3986 -notes that its use should be obsolete because in the context of Common -Lisp Pathnames all need a lookup mechanism to be resolved or they -wouldn't be of much use. +We use the term URL as shorthand in describing the URL Pathnames, even +though the corresponding encoding is more akin to a URI as described +in RFC3986. + Goals ----- @@ -34,7 +34,7 @@ 3. Use URL schemes that are understood by the java.net.URL object. - A file specified by URL + Example of a Pathname specified by URL: #p"http://example.org/org/armedbear/systems/pgp.asd" @@ -49,17 +49,20 @@ 6. TRUENAME "aliased" to PROBE-FILE signalling an error if the URL is not accessible (see "Non-goal 1"). -7. DIRECTORY for non-wildcards +7. DIRECTORY works for non-wildcards. 8. URL pathname work as a valid argument for OPEN with :DIRECTION :INPUT. 9. Enable the loading of ASDF2 systems referenced by a URL pathname. -10. The reserved URL characters (`~`, `/`, `?`, etc.) shall be -encoded in the proper manner on construction of the Pathname. +10. Pathnames constructed with the "file" scheme +(i.e. #p"file:/this/file") need to be properly URI encoded according +to RFC3986 or otherwise will signal FILE-ERROR. 11. The "file" scheme will continue to be represented by an -"ordinary" Pathname. +"ordinary" Pathname. Thus, after construction of a URL Pathname with +the "file" scheme, the namestring of the resulting PATHNAME will no +longer contain the "file:" prefix. 12. The "jar" scheme will continue to be represented by a jar Pathname. @@ -68,10 +71,10 @@ Non-goals --------- -1. We will not implement canonicalization of URL schemas (such as following -"http" redirects). +1. We will not implement canonicalization of URL schemas (such as +following "http" redirects). -2. DIRECTORY working for URL pathnames containing wildcards. +2. DIRECTORY will not work for URL pathnames containing wildcards. Implementation @@ -119,4 +122,11 @@ Status ------ -This design is a proposal. +This design has been implemented. + +History +------- + +26 NOV 2010 Changed implemenation to use URI encodings for the "file" + schemes including those nested with the "jar" scheme by like + aka. "jar:file:/location/of/some.jar!/". From mevenson at common-lisp.net Mon Nov 29 09:20:15 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 29 Nov 2010 04:20:15 -0500 Subject: [armedbear-cvs] r13068 - trunk/abcl Message-ID: Author: mevenson Date: Mon Nov 29 04:20:14 2010 New Revision: 13068 Log: Update CHANGES for abcl-0.23.1. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Mon Nov 29 04:20:14 2010 @@ -1,3 +1,22 @@ +Version 0.23.1 +============== +svn://common-lisp.net/project/armedbear/svn/tags/0.23.0/abcl +(unreleased) + +Fixes +----- + +* [svn r13509-10] Allow JSR-223 clients to query ABCL metadata without + incurring the entire interpreter startup time. + +* [svn r13506] Fix probles with loading FASLs in directories + containing whitespace characters. + + We now require all PATHNAME objects constructed via a namestring + containing the "file" scheme to be URI encoded according to + RFC3986. + + Version 0.23 ============ svn://common-lisp.net/project/armedbear/svn/tags/0.23.0/abcl @@ -16,6 +35,12 @@ Fixes ----- +* [svn r13034] ASDF-INSTALL now searches for location of gpg in a more + comprehensive manner. + +* [ticket #108][svn r13027] Fix problems with ADSF-INSTALL failing to + download systems. + * [svn r12995-12997] Changes to generated byte code to prevent JRockit JVM from crashing when optimizing it From mevenson at common-lisp.net Mon Nov 29 09:26:04 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 29 Nov 2010 04:26:04 -0500 Subject: [armedbear-cvs] r13069 - branches/0.23.x/abcl Message-ID: Author: mevenson Date: Mon Nov 29 04:26:04 2010 New Revision: 13069 Log: Backport CHANGES for abcl-0.23.1. Modified: branches/0.23.x/abcl/CHANGES Modified: branches/0.23.x/abcl/CHANGES ============================================================================== --- branches/0.23.x/abcl/CHANGES (original) +++ branches/0.23.x/abcl/CHANGES Mon Nov 29 04:26:04 2010 @@ -1,3 +1,22 @@ +Version 0.23.1 +============== +svn://common-lisp.net/project/armedbear/svn/tags/0.23.1/abcl +(unreleased) + +Fixes +----- + +* [svn r13509-10] Allow JSR-223 clients to query ABCL metadata without + incurring the entire interpreter startup time. + +* [svn r13506] Fix probles with loading FASLs in directories + containing whitespace characters. + + We now require all PATHNAME objects constructed via a namestring + containing the "file" scheme to be URI encoded according to + RFC3986. + + Version 0.23 ============ svn://common-lisp.net/project/armedbear/svn/tags/0.23.0/abcl @@ -24,7 +43,8 @@ * [ticket #108][svn r13027] Fix download problems with ASDF-INSTALL -* [ticket #110][svn r13024,r13026] Fix #\+ in JAR pathnames does not work +* [ticket #108][svn r13027] Fix problems with ADSF-INSTALL failing to + download systems. * [svn r12995-12997] Changes to generated byte code to prevent JRockit JVM from crashing when optimizing it From mevenson at common-lisp.net Mon Nov 29 09:27:18 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 29 Nov 2010 04:27:18 -0500 Subject: [armedbear-cvs] r13070 - trunk/abcl Message-ID: Author: mevenson Date: Mon Nov 29 04:27:18 2010 New Revision: 13070 Log: Synchronize CHANGES with 0.23.x branch. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Mon Nov 29 04:27:18 2010 @@ -1,6 +1,6 @@ Version 0.23.1 ============== -svn://common-lisp.net/project/armedbear/svn/tags/0.23.0/abcl +svn://common-lisp.net/project/armedbear/svn/tags/0.23.1/abcl (unreleased) Fixes @@ -32,14 +32,16 @@ * [svn r12994] New java-interop macros: CHAIN and JMETHOD-LET +* [svn r13030-31,r13034] ASDF-INSTALL improvements: Ensure that the + ASDF registry contains the ASDF-INSTALL locations. Better + resolution mechanism for 'gpg' binary. + Fixes ----- -* [svn r13034] ASDF-INSTALL now searches for location of gpg in a more - comprehensive manner. +* [svn r13039] Restore the Lisp-based build -* [ticket #108][svn r13027] Fix problems with ADSF-INSTALL failing to - download systems. +* [ticket #108][svn r13027] Fix download problems with ASDF-INSTALL * [svn r12995-12997] Changes to generated byte code to prevent JRockit JVM from crashing when optimizing it From mevenson at common-lisp.net Tue Nov 30 19:58:16 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 30 Nov 2010 14:58:16 -0500 Subject: [armedbear-cvs] r13071 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Nov 30 14:58:15 2010 New Revision: 13071 Log: Add support for writing Java interfaces via the classwriter. One can create interfaces as follows: (let* ((class-name (make-jvm-class-name "org/not/Foo")) (class (make-class-file class-name +java-object+ '(:public :interface))) (method (make-jvm-method "callback" :int '(:int) :flags '(:public :abstract)))) (class-add-method class method) (finalize-class-file class) (with-open-file (s #p"Foo.class" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (write-class-file class s))) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Nov 30 14:58:15 2010 @@ -778,6 +778,7 @@ (:synchronized #x0020) (:transient #x0080) (:native #x0100) + (:interface #x0200) (:abstract #x0400) (:strict #x0800)) "List of keyword symbols used for human readable representation of (access) From mevenson at common-lisp.net Tue Nov 30 20:43:05 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 30 Nov 2010 15:43:05 -0500 Subject: [armedbear-cvs] r13072 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Nov 30 15:43:05 2010 New Revision: 13072 Log: Sockets can be created with :element-type equivalent to (UNSIGNED-BYTE 8). Fixes error reported by Cyrus Harmon where passing an :ELEMENT-TYPE of FLEXI-STREAMS:OCTET to the GET-SOCKET-STREAM call would fail. Modified: trunk/abcl/src/org/armedbear/lisp/socket.lisp Modified: trunk/abcl/src/org/armedbear/lisp/socket.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/socket.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/socket.lisp Tue Nov 30 15:43:05 2010 @@ -35,7 +35,9 @@ ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER. EXTERNAL-FORMAT must be of the same format as specified for OPEN." (cond ((eq element-type 'character)) - ((equal element-type '(unsigned-byte 8))) + ((reduce #'equal + (mapcar #'sys::normalize-type + (list element-type '(unsigned-byte 8))))) (t (error 'simple-type-error :format-control