From ehuelsmann at common-lisp.net  Sun Aug  1 09:59:15 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 01 Aug 2010 05:59:15 -0400
Subject: [armedbear-cvs] r12841 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OfVK7-0002O5-6d@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug  1 05:59:11 2010
New Revision: 12841

Log:
Fix dual-mode: the new style requires type specifiers, not strings.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Aug  1 05:59:11 2010
@@ -462,11 +462,10 @@
   (let* ((info (get-descriptor-info arg-types return-type))
          (descriptor (car info))
          (stack-effect (cdr info))
-         (class-name (!class-name class-name))
          (index (if (null *current-code-attribute*)
-                    (pool-method class-name method-name descriptor)
+                    (pool-method (!class-name class-name) method-name descriptor)
                     (pool-add-method-ref *pool* class-name
-                                         method-name descriptor)))
+                                         method-name (cons return-type arg-types))))
          (instruction (apply #'%emit 'invokestatic (u2 index))))
     (setf (instruction-stack instruction) stack-effect)))
 
@@ -488,11 +487,10 @@
   (let* ((info (get-descriptor-info arg-types return-type))
          (descriptor (car info))
          (stack-effect (cdr info))
-         (class-name (!class-name class-name))
          (index (if (null *current-code-attribute*)
-                    (pool-method class-name method-name descriptor)
+                    (pool-method (!class-name class-name) method-name descriptor)
                     (pool-add-method-ref *pool* class-name
-                                         method-name descriptor)))
+                                         method-name (cons return-type arg-types))))
          (instruction (apply #'%emit 'invokevirtual (u2 index))))
     (declare (type (signed-byte 8) stack-effect))
     (let ((explain *explain*))
@@ -510,11 +508,10 @@
   (let* ((info (get-descriptor-info arg-types nil))
          (descriptor (car info))
          (stack-effect (cdr info))
-         (class-name (!class-name class-name))
          (index (if (null *current-code-attribute*)
-                    (pool-method class-name "<init>" descriptor)
+                    (pool-method (!class-name  class-name) "<init>" descriptor)
                     (pool-add-method-ref *pool* class-name
-                                         "<init>" descriptor)))
+                                         "<init>" (cons nil arg-types))))
          (instruction (apply #'%emit 'invokespecial (u2 index))))
     (declare (type (signed-byte 8) stack-effect))
     (setf (instruction-stack instruction) (1- stack-effect))))



From ehuelsmann at common-lisp.net  Sun Aug  1 10:00:07 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 01 Aug 2010 06:00:07 -0400
Subject: [armedbear-cvs] r12842 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OfVKx-0002Uo-6h@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug  1 06:00:01 2010
New Revision: 12842

Log:
Two fixes from test-writing.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Sun Aug  1 06:00:01 2010
@@ -631,7 +631,7 @@
   descriptor
   attributes)
 
-(defun make-field (name type &key (flags '(:public)))
+(defun !make-field (name type &key (flags '(:public)))
   
   (%make-field :access-flags flags
                :name name
@@ -649,7 +649,7 @@
     (setf (field-access-flags field)
           (map-flags (field-access-flags field))
           (field-descriptor field)
-          (pool-add-utf8 pool (internal-field-type (field-descriptor field)))
+          (pool-add-utf8 pool (internal-field-ref (field-descriptor field)))
           (field-name field)
           (pool-add-utf8 pool (field-name field))))
   (finalize-attributes (field-attributes field) nil class))



From ehuelsmann at common-lisp.net  Sun Aug  1 10:23:52 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 01 Aug 2010 06:23:52 -0400
Subject: [armedbear-cvs] r12843 -
	branches/generic-class-file/abcl/test/lisp/abcl
Message-ID: <E1OfVhw-0005EW-MO@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug  1 06:23:51 2010
New Revision: 12843

Log:
New tests.

Modified:
   branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp

Modified: branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp	(original)
+++ branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp	Sun Aug  1 06:23:51 2010
@@ -190,7 +190,7 @@
            (method (jvm::!make-method :class-constructor :void nil
                                       :flags '(:static))))
       (jvm::class-add-method file method)
-      (jvm::with-code-to-method (method)
+      (jvm::with-code-to-method (file method)
         (jvm::emit 'return))
       (jvm::finalize-class-file file)
       (with-open-stream (stream (sys::%make-byte-array-output-stream))
@@ -204,7 +204,7 @@
            (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))
            (method (jvm::!make-method "doNothing" :void nil)))
       (jvm::class-add-method file method)
-      (jvm::with-code-to-method (method)
+      (jvm::with-code-to-method (file method)
         (let ((label1 (gensym))
               (label2 (gensym))
               (label3 (gensym)))
@@ -223,6 +223,129 @@
       T)
   T)
 
+;; generation of an ABCL-like function class
+(deftest generate-method.3
+    (let* ((class (jvm::make-class-name "org.armedbear.lisp.gm_3"))
+           (file (jvm::!make-class-file class jvm::+lisp-primitive+ '(:public)))
+           )
+      (let ((method (jvm::!make-method :constructor :void nil)))
+        (jvm::class-add-method file method)
+        (jvm::with-code-to-method (file method)
+          (jvm::emit 'aload 0)
+          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+          (jvm::emit-invokespecial-init jvm::+lisp-primitive+
+                                        (list jvm::+lisp-object+
+                                              jvm::+lisp-object+))
+          (jvm::emit 'return)))
+      (let ((method (jvm::!make-method "execute" jvm::+lisp-object+ nil)))
+        (jvm::class-add-method file method)
+        (jvm::with-code-to-method (file method)
+          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+          (jvm::emit 'jvm::areturn)))
+      (jvm::finalize-class-file file)
+      (with-open-stream (stream (sys::%make-byte-array-output-stream))
+        (jvm::!write-class-file file stream)
+        (funcall (sys::load-compiled-function (sys::%get-output-stream-bytes stream)))))
+  NIL)
+
+;; generation of an ABCL-like function class with static init function and
+;; static field
+(deftest generate-method.4
+    (let* ((class (jvm::make-class-name "org.armedbear.lisp.gm_4"))
+           (file (jvm::!make-class-file class jvm::+lisp-primitive+ '(:public)))
+           )
+      (jvm::class-add-field file (jvm::!make-field "N1" jvm::+lisp-object+
+                                                  :flags '(:static :private)))
+      (let ((method (jvm::!make-method :class-constructor :void nil :flags '(:static))))
+        (jvm::class-add-method file method)
+        (jvm::with-code-to-method (file method)
+          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+          (jvm::emit-putstatic class "N1" jvm::+lisp-object+)
+          (jvm::emit 'return)))
+      (let ((method (jvm::!make-method :constructor :void nil)))
+        (jvm::class-add-method file method)
+        (jvm::with-code-to-method (file method)
+          (jvm::emit 'aload 0)
+          (jvm::emit-getstatic class "N1" jvm::+lisp-object+)
+          (jvm::emit-getstatic class "N1" jvm::+lisp-object+)
+          (jvm::emit-invokespecial-init jvm::+lisp-primitive+
+                                        (list jvm::+lisp-object+
+                                              jvm::+lisp-object+))
+          (jvm::emit 'return)))
+      (let ((method (jvm::!make-method "execute" jvm::+lisp-object+ nil)))
+        (jvm::class-add-method file method)
+        (jvm::with-code-to-method (file method)
+          (jvm::emit-getstatic class "N1" jvm::+lisp-object+)
+          (jvm::emit 'jvm::areturn)))
+      (jvm::finalize-class-file file)
+      (with-open-stream (stream (sys::%make-byte-array-output-stream))
+        (jvm::!write-class-file file stream)
+        (funcall (sys::load-compiled-function (sys::%get-output-stream-bytes stream)))))
+  NIL)
+
+
+;; generation of ABCL-like function class with multiple 'execute' methods
+(deftest generate-method.5
+    (let* ((class (jvm::make-class-name "org.armedbear.lisp.gm_5"))
+           (file (jvm::!make-class-file class jvm::+lisp-primitive+ '(:public)))
+           )
+      (let ((method (jvm::!make-method :constructor :void nil)))
+        (jvm::class-add-method file method)
+        (jvm::with-code-to-method (file method)
+          (jvm::emit 'aload 0)
+          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+          (jvm::emit-invokespecial-init jvm::+lisp-primitive+
+                                        (list jvm::+lisp-object+
+                                              jvm::+lisp-object+))
+          (jvm::emit 'return)))
+      (let ((method (jvm::!make-method "execute" jvm::+lisp-object+ nil)))
+        (jvm::class-add-method file method)
+        (jvm::with-code-to-method (file method)
+          (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+          (jvm::emit 'jvm::areturn)))
+      (let ((method (jvm::!make-method "execute" jvm::+lisp-object+
+                                       (list jvm::+lisp-object+))))
+        (jvm::class-add-method file method)
+        (jvm::with-code-to-method (file method)
+          (jvm::emit-getstatic jvm::+lisp+ "T" jvm::+lisp-symbol+)
+          (jvm::emit 'jvm::areturn)))
+      (jvm::finalize-class-file file)
+      (with-open-stream (stream (sys::%make-byte-array-output-stream))
+        (jvm::!write-class-file file stream)
+        (let* ((bytes (sys::%get-output-stream-bytes stream))
+               (fn (sys::load-compiled-function bytes)))
+          (values (funcall fn) (funcall fn NIL)))))
+  NIL T)
+
+;; ;;  generation of an ABCL-like function, with mixed output to constructor,
+;; ;;  static initializer and function method(s)
+;; (deftest generate-method.6
+;;     (let* ((class (jvm::make-class-name "org.armedbear.lisp.gm_6"))
+;;            (file (jvm::!make-class-file class jvm::+lisp-primitive+ '(:public)))
+;;            )
+;;       (let ((method (jvm::!make-method :constructor :void nil)))
+;;         (jvm::class-add-method file method)
+;;         (jvm::with-code-to-method (file method)
+;;           (jvm::emit 'aload 0)
+;;           (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+;;           (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+;;           (jvm::emit-invokespecial-init jvm::+lisp-primitive+
+;;                                         (list jvm::+lisp-object+
+;;                                               jvm::+lisp-object+))
+;;           (jvm::emit 'return)))
+;;       (let ((method (jvm::!make-method "execute" jvm::+lisp-object+ nil)))
+;;         (jvm::class-add-method file method)
+;;         (jvm::with-code-to-method (file method)
+;;           (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+)
+;;           (jvm::emit 'jvm::areturn)))
+;;       (jvm::finalize-class-file file)
+;;       (with-open-stream (stream (sys::%make-byte-array-output-stream))
+;;         (jvm::!write-class-file file stream)
+;;         (ignore-errors (sys::load-compiled-function nil))
+;;         (funcall (sys::load-compiled-function (sys::%get-output-stream-bytes stream))))
+;;       T
+;;       )
+;;   T)
 
-;;(deftest generate-method.2
-;;    (let* ((class))))
\ No newline at end of file



From ehuelsmann at common-lisp.net  Sun Aug  1 18:05:07 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 01 Aug 2010 14:05:07 -0400
Subject: [armedbear-cvs] r12844 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OfcuJ-0000Wc-Nz@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug  1 14:05:04 2010
New Revision: 12844

Log:
Centralize exception-handler registration/accumulation;
while at it, remove a utility function from jvm-class-file.lisp
which should have been in compiler-pass2.lisp.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Aug  1 14:05:04 2010
@@ -199,6 +199,19 @@
           n)))
 
 
+(defun add-exception-handler (start end handler type)
+  (if (null *current-code-attribute*)
+      (push (make-handler :from start
+                          :to end
+                          :code handler
+                          :catch-type (if (null type)
+                                          0
+                                          (pool-class (!class-name type))))
+            *handlers*)
+      (code-add-exception-handler *current-code-attribute*
+                                  start end handler type)))
+
+
 (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
 (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;")
 (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum")
@@ -3971,10 +3984,7 @@
     ;; Restore dynamic environment.
     (label label-EXIT)
     (restore-dynamic-environment register)
-    (push (make-handler :from label-START
-			:to label-END
-			:code label-END
-			:catch-type 0) *handlers*)))
+    (add-exception-handler label-START label-END label-END nil)))
 
 (defun p2-m-v-b-node (block target)
   (let* ((*register* *register*)
@@ -4506,16 +4516,8 @@
         (emit-move-to-variable (tagbody-id-variable block))
         (emit 'athrow)
         ;; Finally...
-        (push (make-handler :from BEGIN-BLOCK
-                            :to END-BLOCK
-                            :code HANDLER
-                            :catch-type (pool-class (!class-name +lisp-go+)))
-              *handlers*)
-        (push (make-handler :from BEGIN-BLOCK
-                            :to END-BLOCK
-                            :code EXTENT-EXIT-HANDLER
-                            :catch-type 0)
-              *handlers*)))
+        (add-exception-handler BEGIN-BLOCK END-BLOCK HANDLER +lisp-go+)
+        (add-exception-handler BEGIN-BLOCK END-BLOCK EXTENT-EXIT-HANDLER nil)))
     (label EXIT)
     (when (tagbody-non-local-go-p block)
       (emit 'aconst_null) ;; load null value
@@ -4677,16 +4679,8 @@
         (emit 'getfield +lisp-return+ "result" +lisp-object+)
         (emit-move-from-stack target) ; Stack depth is 0.
         ;; Finally...
-        (push (make-handler :from BEGIN-BLOCK
-                            :to END-BLOCK
-                            :code HANDLER
-                            :catch-type (pool-class (!class-name +lisp-return+)))
-              *handlers*)
-        (push (make-handler :from BEGIN-BLOCK
-                            :to END-BLOCK
-                            :code EXTENT-EXIT-HANDLER
-                            :catch-type 0)
-              *handlers*)))
+        (add-exception-handler BEGIN-BLOCK END-BLOCK HANDLER +lisp-return+)
+        (add-exception-handler BEGIN-BLOCK END-BLOCK EXTENT-EXIT-HANDLER nil)))
     (label BLOCK-EXIT)
     (when (block-id-variable block)
       (emit 'aconst_null) ;; load null value
@@ -7622,10 +7616,9 @@
     (label EXIT)
     (aload object-register)
     (emit 'monitorexit)
-    (push (make-handler :from BEGIN-PROTECTED-RANGE
-                        :to END-PROTECTED-RANGE
-                        :code END-PROTECTED-RANGE
-                        :catch-type 0) *handlers*)))
+    (add-exception-handler BEGIN-PROTECTED-RANGE
+                           END-PROTECTED-RANGE
+                           END-PROTECTED-RANGE nil)))
 
 
 (defknown p2-catch-node (t t) t)
@@ -7676,16 +7669,12 @@
       ;; Finally...
       (emit-push-current-thread)
       (emit-invokevirtual +lisp-thread+ "popCatchTag" nil nil)
-      (let ((handler1 (make-handler :from BEGIN-PROTECTED-RANGE
-                                    :to END-PROTECTED-RANGE
-                                    :code THROW-HANDLER
-                                    :catch-type (pool-class (!class-name +lisp-throw+))))
-            (handler2 (make-handler :from BEGIN-PROTECTED-RANGE
-                                    :to END-PROTECTED-RANGE
-                                    :code DEFAULT-HANDLER
-                                    :catch-type 0)))
-        (push handler1 *handlers*)
-        (push handler2 *handlers*))))
+      (add-exception-handler BEGIN-PROTECTED-RANGE
+                             END-PROTECTED-RANGE
+                             THROW-HANDLER +lisp-throw+)
+      (add-exception-handler BEGIN-PROTECTED-RANGE
+                             END-PROTECTED-RANGE
+                             DEFAULT-HANDLER nil)))
   t)
 
 (defun p2-throw (form target representation)
@@ -7771,11 +7760,8 @@
       ;; Result.
       (aload result-register)
       (emit-move-from-stack target)
-      (let ((handler (make-handler :from BEGIN-PROTECTED-RANGE
-                                   :to END-PROTECTED-RANGE
-                                   :code HANDLER
-                                   :catch-type 0)))
-        (push handler *handlers*)))))
+      (add-exception-handler BEGIN-PROTECTED-RANGE
+                             END-PROTECTED-RANGE HANDLER nil))))
 
 (defknown compile-form (t t t) t)
 (defun compile-form (form target representation)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Sun Aug  1 14:05:04 2010
@@ -864,9 +864,6 @@
                         :catch-type type)
         (code-exception-handlers code)))
 
-(defun add-exception-handler (start end handler type)
-  (code-add-exception-handler *current-code-attribute* start end handler type))
-
 (defstruct exception
   start-pc    ;; label target
   end-pc      ;; label target



From ehuelsmann at common-lisp.net  Sun Aug  1 21:16:49 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 01 Aug 2010 17:16:49 -0400
Subject: [armedbear-cvs] r12845 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Offtp-0004lz-3p@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug  1 17:16:48 2010
New Revision: 12845

Log:
Continued integration of CLASS-NAME: use it for 
+lisp-fixnum+ and +lisp-bignum+.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Aug  1 17:16:48 2010
@@ -214,11 +214,7 @@
 
 (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
 (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;")
-(defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum")
-(defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;")
 (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;")
-(defconstant +lisp-bignum-class+ "org/armedbear/lisp/Bignum")
-(defconstant +lisp-bignum+ "Lorg/armedbear/lisp/Bignum;")
 (defconstant +lisp-single-float-class+ "org/armedbear/lisp/SingleFloat")
 (defconstant +lisp-single-float+ "Lorg/armedbear/lisp/SingleFloat;")
 (defconstant +lisp-double-float-class+ "org/armedbear/lisp/DoubleFloat")
@@ -766,7 +762,7 @@
                             (CHARACTER  +lisp-character+)
                             (CONS       +lisp-cons+)
                             (HASH-TABLE +lisp-hash-table+)
-                            (FIXNUM     +lisp-fixnum-class+)
+                            (FIXNUM     +lisp-fixnum+)
                             (STREAM     +lisp-stream+)
                             (STRING     +lisp-abstract-string+)
                             (VECTOR     +lisp-abstract-vector+)))
@@ -917,15 +913,15 @@
 (defun emit-unbox-fixnum ()
   (declare (optimize speed))
   (cond ((= *safety* 3)
-         (emit-invokestatic +lisp-fixnum-class+ "getValue"
+         (emit-invokestatic +lisp-fixnum+ "getValue"
                             (lisp-object-arg-types 1) "I"))
         (t
-         (emit 'checkcast +lisp-fixnum-class+)
-         (emit 'getfield +lisp-fixnum-class+ "value" "I"))))
+         (emit 'checkcast +lisp-fixnum+)
+         (emit 'getfield +lisp-fixnum+ "value" "I"))))
 
 (defknown emit-unbox-long () t)
 (defun emit-unbox-long ()
-  (emit-invokestatic +lisp-bignum-class+ "longValue"
+  (emit-invokestatic +lisp-bignum+ "longValue"
                      (lisp-object-arg-types 1) "J"))
 
 (defknown emit-unbox-float () t)
@@ -956,8 +952,8 @@
         ((eq required-representation :int)
          (cond ((and (fixnum-type-p derived-type)
                      (< *safety* 3))
-                (emit 'checkcast +lisp-fixnum-class+)
-                (emit 'getfield +lisp-fixnum-class+ "value" "I"))
+                (emit 'checkcast +lisp-fixnum+)
+                (emit 'getfield +lisp-fixnum+ "value" "I"))
                (t
                 (emit-invokevirtual +lisp-object+ "intValue" nil "I"))))
         ((eq required-representation :char)
@@ -2042,23 +2038,23 @@
 (defun serialize-integer (n)
   "Generates code to restore a serialized integer."
   (cond((<= 0 n 255)
-        (emit-getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
+        (emit-getstatic +lisp-fixnum+ "constants" +lisp-fixnum-array+)
         (emit-push-constant-int n)
         (emit 'aaload))
        ((<= most-negative-fixnum n most-positive-fixnum)
         (emit-push-constant-int n)
-        (emit-invokestatic +lisp-fixnum-class+ "getInstance"
+        (emit-invokestatic +lisp-fixnum+ "getInstance"
                            '("I") +lisp-fixnum+))
        ((<= most-negative-java-long n most-positive-java-long)
         (emit-push-constant-long n)
-        (emit-invokestatic +lisp-bignum-class+ "getInstance"
+        (emit-invokestatic +lisp-bignum+ "getInstance"
                            '("J") +lisp-integer+))
        (t
         (let* ((*print-base* 10)
                (s (with-output-to-string (stream) (dump-form n stream))))
           (emit 'ldc (pool-string s))
           (emit-push-constant-int 10)
-          (emit-invokestatic +lisp-bignum-class+ "getInstance"
+          (emit-invokestatic +lisp-bignum+ "getInstance"
                              (list +java-string+ "I") +lisp-integer+)))))
 
 (defun serialize-character (c)
@@ -3384,7 +3380,7 @@
   'ifne)
 
 (defun p2-test-fixnump (form)
-  (p2-test-instanceof-predicate form +lisp-fixnum-class+))
+  (p2-test-instanceof-predicate form +lisp-fixnum+))
 
 (defun p2-test-stringp (form)
   (p2-test-instanceof-predicate form +lisp-abstract-string+))
@@ -4607,7 +4603,7 @@
   (p2-instanceof-predicate form target representation +lisp-cons+))
 
 (defun p2-fixnump (form target representation)
-  (p2-instanceof-predicate form target representation +lisp-fixnum-class+))
+  (p2-instanceof-predicate form target representation +lisp-fixnum+))
 
 (defun p2-packagep (form target representation)
   (p2-instanceof-predicate form target representation +lisp-package+))
@@ -7435,7 +7431,7 @@
                             (CHARACTER  +lisp-character+)
                             (CONS       +lisp-cons+)
                             (HASH-TABLE +lisp-hash-table+)
-                            (FIXNUM     +lisp-fixnum-class+)
+                            (FIXNUM     +lisp-fixnum+)
 			    (STREAM     +lisp-stream+)
                             (STRING     +lisp-abstract-string+)
                             (VECTOR     +lisp-abstract-vector+)))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Sun Aug  1 17:16:48 2010
@@ -113,8 +113,8 @@
 (define-class-name +lisp-thread+ "org.armedbear.lisp.LispThread")
 (define-class-name +lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding")
 (define-class-name +lisp-integer+ "org.armedbear.lisp.LispInteger")
-(define-class-name +!lisp-fixnum+ "org.armedbear.lisp.Fixnum")
-(define-class-name +!lisp-bignum+ "org.armedbear.lisp.Bignum")
+(define-class-name +lisp-fixnum+ "org.armedbear.lisp.Fixnum")
+(define-class-name +lisp-bignum+ "org.armedbear.lisp.Bignum")
 (define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat")
 (define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat")
 (define-class-name +lisp-cons+ "org.armedbear.lisp.Cons")



From ehuelsmann at common-lisp.net  Sun Aug  1 21:31:07 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 01 Aug 2010 17:31:07 -0400
Subject: [armedbear-cvs] r12846 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ofg7e-0005la-VU@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug  1 17:31:06 2010
New Revision: 12846

Log:
Continued integration of CLASS-NAME: use it for 
+lisp-single-float+ and +lisp-double-float+.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Aug  1 17:31:06 2010
@@ -215,10 +215,6 @@
 (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
 (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;")
 (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;")
-(defconstant +lisp-single-float-class+ "org/armedbear/lisp/SingleFloat")
-(defconstant +lisp-single-float+ "Lorg/armedbear/lisp/SingleFloat;")
-(defconstant +lisp-double-float-class+ "org/armedbear/lisp/DoubleFloat")
-(defconstant +lisp-double-float+ "Lorg/armedbear/lisp/DoubleFloat;")
 (defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;")
 (defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;")
 
@@ -638,8 +634,8 @@
     (:char    . ,+lisp-character+)
     (:int     . ,+lisp-integer+)
     (:long    . ,+lisp-integer+)
-    (:float   . ,+!lisp-single-float+)
-    (:double  . ,+!lisp-double-float+))
+    (:float   . ,+lisp-single-float+)
+    (:double  . ,+lisp-double-float+))
   "Lists the class on which to call the `getInstance' method on,
 when converting the internal representation to a LispObject.")
 
@@ -928,21 +924,21 @@
 (defun emit-unbox-float ()
   (declare (optimize speed))
   (cond ((= *safety* 3)
-         (emit-invokestatic +lisp-single-float-class+ "getValue"
+         (emit-invokestatic +lisp-single-float+ "getValue"
                             (lisp-object-arg-types 1) "F"))
         (t
-         (emit 'checkcast +lisp-single-float-class+)
-         (emit 'getfield +lisp-single-float-class+ "value" "F"))))
+         (emit 'checkcast +lisp-single-float+)
+         (emit 'getfield +lisp-single-float+ "value" "F"))))
 
 (defknown emit-unbox-double () t)
 (defun emit-unbox-double ()
   (declare (optimize speed))
   (cond ((= *safety* 3)
-         (emit-invokestatic +lisp-double-float-class+ "getValue"
+         (emit-invokestatic +lisp-double-float+ "getValue"
                             (lisp-object-arg-types 1) "D"))
         (t
-         (emit 'checkcast +lisp-double-float-class+)
-         (emit 'getfield +lisp-double-float-class+ "value" "D"))))
+         (emit 'checkcast +lisp-double-float+)
+         (emit 'getfield +lisp-double-float+ "value" "D"))))
 
 (defknown fix-boxing (t t) t)
 (defun fix-boxing (required-representation derived-type)
@@ -2065,17 +2061,17 @@
 
 (defun serialize-float (s)
   "Generates code to restore a serialized single-float."
-  (emit 'new +lisp-single-float-class+)
+  (emit 'new +lisp-single-float+)
   (emit 'dup)
   (emit 'ldc (pool-float s))
-  (emit-invokespecial-init +lisp-single-float-class+ '("F")))
+  (emit-invokespecial-init +lisp-single-float+ '("F")))
 
 (defun serialize-double (d)
   "Generates code to restore a serialized double-float."
-  (emit 'new +lisp-double-float-class+)
+  (emit 'new +lisp-double-float+)
   (emit 'dup)
   (emit 'ldc2_w (pool-double d))
-  (emit-invokespecial-init +lisp-double-float-class+ '("D")))
+  (emit-invokespecial-init +lisp-double-float+ '("D")))
 
 (defun serialize-string (string)
   "Generate code to restore a serialized string."
@@ -2127,8 +2123,8 @@
 (defvar serialization-table
   `((integer "INT" ,#'eql ,#'serialize-integer ,+lisp-integer+)
     (character "CHR" ,#'eql ,#'serialize-character ,+lisp-character+)
-    (single-float "FLT" ,#'eql ,#'serialize-float ,+!lisp-single-float+)
-    (double-float "DBL" ,#'eql ,#'serialize-double ,+!lisp-double-float+)
+    (single-float "FLT" ,#'eql ,#'serialize-float ,+lisp-single-float+)
+    (double-float "DBL" ,#'eql ,#'serialize-double ,+lisp-double-float+)
     (string "STR" ,#'equal ,#'serialize-string
             ,+lisp-abstract-string+) ;; because of (not compile-file)
     (package "PKG" ,#'eq ,#'serialize-package ,+lisp-object+)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Sun Aug  1 17:31:06 2010
@@ -115,8 +115,8 @@
 (define-class-name +lisp-integer+ "org.armedbear.lisp.LispInteger")
 (define-class-name +lisp-fixnum+ "org.armedbear.lisp.Fixnum")
 (define-class-name +lisp-bignum+ "org.armedbear.lisp.Bignum")
-(define-class-name +!lisp-single-float+ "org.armedbear.lisp.SingleFloat")
-(define-class-name +!lisp-double-float+ "org.armedbear.lisp.DoubleFloat")
+(define-class-name +lisp-single-float+ "org.armedbear.lisp.SingleFloat")
+(define-class-name +lisp-double-float+ "org.armedbear.lisp.DoubleFloat")
 (define-class-name +lisp-cons+ "org.armedbear.lisp.Cons")
 (define-class-name +lisp-load+ "org.armedbear.lisp.Load")
 (define-class-name +lisp-character+ "org.armedbear.lisp.LispCharacter")



From mevenson at common-lisp.net  Mon Aug  2 06:07:36 2010
From: mevenson at common-lisp.net (Mark Evenson)
Date: Mon, 02 Aug 2010 02:07:36 -0400
Subject: [armedbear-cvs] r12847 - trunk/abcl
Message-ID: <E1OfoBU-0003wh-4P@common-lisp.net>

Author: mevenson
Date: Mon Aug  2 02:07:33 2010
New Revision: 12847

Log:
Remove possible FASL artifacts from source directory.

When working on ABCL from SLIME, one often inadvertently creates FASL
artifacts in the source directory, which can interfere with
system compilation.



Modified:
   trunk/abcl/build.xml

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Mon Aug  2 02:07:33 2010
@@ -234,8 +234,13 @@
       <echo>
 Compiling Lisp system 
 from ${abcl.home.dir}
-to   ${abcl.lisp.output}</echo>
-      <java classpath="${build.classes.dir}" 
+ to  ${abcl.lisp.output}</echo>
+ 
+     <!-- Not good if ${abcl.home.dir} == ${abcl.lisp.output} -->
+     <delete>
+       <fileset dir="${abcl.home.dir}" includes="**/*.abcl **/*.cls **/*._"/>
+     </delete>
+     <java classpath="${build.classes.dir}" 
 	    fork="true"
 	    failonerror="true"
             inputstring="(handler-case (compile-system :zip nil :quit t :output-path &quot;${abcl.lisp.output}/&quot;) (t (x) (progn (format t &quot;~A: ~A~%&quot; (type-of x) x) (exit :status -1))))"



From mevenson at common-lisp.net  Mon Aug  2 06:07:39 2010
From: mevenson at common-lisp.net (Mark Evenson)
Date: Mon, 02 Aug 2010 02:07:39 -0400
Subject: [armedbear-cvs] r12848 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1OfoBX-0003xI-Sq@common-lisp.net>

Author: mevenson
Date: Mon Aug  2 02:07:39 2010
New Revision: 12848

Log:
Small documentation corrections.



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

Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Mon Aug  2 02:07:39 2010
@@ -619,7 +619,7 @@
    * argument <tt>arg</tt> in a <tt>CacheEntry</tt>
    *
    * <p>In the simplest case, when this generic function
-   * does not have EQL specialized methos, and therefore
+   * does not have EQL specialized methods, and therefore
    * only argument types are relevant for choosing
    * applicable methods, the value returned is the 
    * class of <tt>arg</tt>
@@ -631,16 +631,16 @@
    *   - otherwise class of the <tt>arg</tt> is returned.
    *
    * <p>Note that we do not consider argument position, when
-   * calculating arg specialization. In rare cases (when
-   * one argument is eql-specialized to a symbol specifying
-   * class of another argument) this may result in redundant cache
-   * entries caching the same method. But the method cached is anyway
-   * correct for the arguments (because in case of cache miss, correct method
-   * is calculated by other code, which does not rely on getArgSpecialization;
-   * and because EQL is true only for objects of the same type, which guaranties
-   * that if a type-specialized methods was chached by eql-specialization,
-   * all the cache hits into this records will be from args of the conforming 
-   * type).
+   * calculating arg specialization. In rare cases (when one argument
+   * is eql-specialized to a symbol specifying class of another
+   * argument) this may result in redundant cache entries caching the
+   * same method. But the method cached is anyway correct for the
+   * arguments (because in case of cache miss, correct method is
+   * calculated by other code, which does not rely on
+   * getArgSpecialization; and because EQL is true only for objects of
+   * the same type, which guaranties that if a type-specialized
+   * methods was chached by eql-specialization, all the cache hits
+   * into this records will be from args of the conforming type).
    *
    * <p>Consider:
    * <pre><tt>



From mevenson at common-lisp.net  Mon Aug  2 06:07:46 2010
From: mevenson at common-lisp.net (Mark Evenson)
Date: Mon, 02 Aug 2010 02:07:46 -0400
Subject: [armedbear-cvs] r12849 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1OfoBe-0003xq-Jz@common-lisp.net>

Author: mevenson
Date: Mon Aug  2 02:07:45 2010
New Revision: 12849

Log:
Narrow LISP-ERROR to STORAGE-CONDITION.

Now JRUN-EXCEPTION-PROTECTED behaves like INTERACTIVE-EVAL which
should be correct.

Include textual message about reason for STORAGE-CONDITION



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

Modified: trunk/abcl/src/org/armedbear/lisp/Java.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Java.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Java.java	Mon Aug  2 02:07:45 2010
@@ -1201,7 +1201,7 @@
                 return LispThread.currentThread().execute(closure);
             }
             catch (OutOfMemoryError oom) {
-                return error(new StorageCondition("Out of memory."));
+                return error(new StorageCondition("Out of memory " + oom.getMessage()));
             }
             catch (StackOverflowError oos) {
                 return error(new StorageCondition("Stack overflow."));

Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java	Mon Aug  2 02:07:45 2010
@@ -277,7 +277,7 @@
           }
         catch (OutOfMemoryError e)
           {
-            return error(new LispError("Out of memory."));
+            return error(new StorageCondition("Out of memory " + e.getMessage()));
           }
         catch (StackOverflowError e)
           {



From ehuelsmann at common-lisp.net  Mon Aug  2 06:41:34 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 02 Aug 2010 02:41:34 -0400
Subject: [armedbear-cvs] r12850 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OfoiM-0006Op-LL@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  2 02:41:33 2010
New Revision: 12850

Log:
Continue CLASS-NAME integration, define a solution for arrays.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  2 02:41:33 2010
@@ -211,13 +211,6 @@
       (code-add-exception-handler *current-code-attribute*
                                   start end handler type)))
 
-
-(defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
-(defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;")
-(defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;")
-(defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;")
-(defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;")
-
 (defun !class-name (class-name)
   "To be eliminated when all hard-coded strings are replaced by `class-name'
 structures"

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Mon Aug  2 02:41:33 2010
@@ -82,9 +82,19 @@
 
 (defstruct (class-name (:conc-name class-)
                        (:constructor %make-class-name))
+  "Used for class identification.
+
+The caller should instantiate only one `class-name' per class, as they are
+used as class identifiers and compared using EQ.
+
+Some instructions need a class argument, others need a reference identifier.
+This class is used to abstract from the difference."
   name-internal
   ref
-  array-ref)
+  array-class ;; cached array class reference
+  ;; keeping a reference to the associated array class allows class
+  ;; name comparisons to be EQ: all classes should exist only once,
+  )
 
 (defun make-class-name (name)
   "Creates a `class-name' structure for the class or interface `name'.
@@ -93,8 +103,26 @@
 to 'internal' (JVM) representation by this function."
   (setf name (substitute #\/ #\. name))
   (%make-class-name :name-internal name
-                    :ref (concatenate 'string "L" name ";")
-                    :array-ref (concatenate 'string "[L" name ";")))
+                    :ref (concatenate 'string "L" name ";")))
+
+(defun class-array (class-name)
+  "Returns a class-name representing an array of `class-name'.
+For multi-dimensional arrays, call this function multiple times, using
+its own result.
+
+This function can be called multiple times on the same `class-name' without
+violating the 'only one instance' requirement: the returned value is cached
+and used on successive calls."
+  (unless (class-array-class class-name)
+    ;; Alessio Stalla found by dumping a class file that the JVM uses
+    ;; the same representation (ie '[L<class-name>;') in CHECKCAST as
+    ;; it does in field references, meaning the class name and class ref
+    ;; 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))))
+  (class-array-class class-name))
 
 (defmacro define-class-name (symbol java-dotted-name &optional documentation)
   "Convenience macro to define constants for `class-name' structures,
@@ -105,6 +133,7 @@
 (define-class-name +java-object+ "java.lang.Object")
 (define-class-name +java-string+ "java.lang.String")
 (define-class-name +lisp-object+ "org.armedbear.lisp.LispObject")
+(defconstant +lisp-object-array+ (class-array +lisp-object+))
 (define-class-name +lisp-simple-string+ "org.armedbear.lisp.SimpleString")
 (define-class-name +lisp+ "org.armedbear.lisp.Lisp")
 (define-class-name +lisp-nil+ "org.armedbear.lisp.Nil")
@@ -112,14 +141,17 @@
 (define-class-name +lisp-symbol+ "org.armedbear.lisp.Symbol")
 (define-class-name +lisp-thread+ "org.armedbear.lisp.LispThread")
 (define-class-name +lisp-closure-binding+ "org.armedbear.lisp.ClosureBinding")
+(defconstant +closure-binding-array+ (class-array +lisp-closure-binding+))
 (define-class-name +lisp-integer+ "org.armedbear.lisp.LispInteger")
 (define-class-name +lisp-fixnum+ "org.armedbear.lisp.Fixnum")
+(defconstant +lisp-fixnum-array+ (class-array +lisp-fixnum+))
 (define-class-name +lisp-bignum+ "org.armedbear.lisp.Bignum")
 (define-class-name +lisp-single-float+ "org.armedbear.lisp.SingleFloat")
 (define-class-name +lisp-double-float+ "org.armedbear.lisp.DoubleFloat")
 (define-class-name +lisp-cons+ "org.armedbear.lisp.Cons")
 (define-class-name +lisp-load+ "org.armedbear.lisp.Load")
 (define-class-name +lisp-character+ "org.armedbear.lisp.LispCharacter")
+(defconstant +lisp-character-array+ (class-array +lisp-character+))
 (define-class-name +lisp-structure-object+ "org.armedbear.lisp.StructureObject")
 (define-class-name +lisp-simple-vector+ "org.armedbear.lisp.SimpleVector")
 (define-class-name +lisp-abstract-string+ "org.armedbear.lisp.AbstractString")
@@ -143,7 +175,8 @@
 (define-class-name +lisp-compiled-closure+ "org.armedbear.lisp.CompiledClosure")
 (define-class-name +lisp-closure-parameter+
     "org.armedbear.lisp.Closure$Parameter")
-(define-class-name +!fasl-loader+ "org.armedbear.lisp.FaslClassLoader")
+(defconstant +lisp-closure-parameter-array+
+  (class-array +lisp-closure-parameter+))
 
 #|
 



From ehuelsmann at common-lisp.net  Mon Aug  2 07:05:46 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 02 Aug 2010 03:05:46 -0400
Subject: [armedbear-cvs] r12851 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ofp5m-00012D-Rh@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  2 03:05:45 2010
New Revision: 12851

Log:
Continue CLASS-NAME integration: use a class-name object in the
CLASS slot of the ABCL-CLASS-FILE structure.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Mon Aug  2 03:05:45 2010
@@ -105,18 +105,21 @@
     (dotimes (i (length name))
       (declare (type fixnum i))
       (when (or (char= (char name i) #\-)
-		(char= (char name i) #\Space))
+                (char= (char name i) #\Space))
         (setf (char name i) #\_)))
-    (concatenate 'string "org/armedbear/lisp/" name)))
+    (make-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."
-  (concatenate 'string "abcl_"
-          (java:jcall (java:jmethod "java.lang.String" "replace" "char" "char")
-                      (java:jcall (java:jmethod "java.util.UUID" "toString")
-                             (java:jstatic "randomUUID" "java.util.UUID"))
-                      #\- #\_)))
+  (make-class-name
+   (concatenate 'string "abcl_"
+                (substitute #\_ #\-
+                            (java:jcall (java:jmethod "java.util.UUID"
+                                                      "toString")
+                                        (java:jstatic "randomUUID"
+                                                      "java.util.UUID"))))))
 
 (defun make-class-file (&key pathname lambda-name lambda-list)
   "Creates a `class-file' structure. If `pathname' is non-NIL, it's



From ehuelsmann at common-lisp.net  Mon Aug  2 10:48:47 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 02 Aug 2010 06:48:47 -0400
Subject: [armedbear-cvs] r12852 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OfsZb-0007Eh-Td@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  2 06:48:45 2010
New Revision: 12852

Log:
Convert GENERATE-LOADER-FUNCTION to use CLASS-NAMEs
instead of literal strings.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp	Mon Aug  2 06:48:45 2010
@@ -672,6 +672,9 @@
 	     (ncase ,expr ,middle ,max ,@(subseq clauses half)))
 	`(case ,expr , at clauses))))
 
+(defconstant +fasl-classloader+
+  (jvm::make-class-name "org.armedbear.lisp.FaslClassLoader"))
+
 (defun generate-loader-function ()
   (let* ((basename (base-classname))
 	 (expr `(lambda (fasl-loader fn-index)
@@ -680,19 +683,22 @@
 		    ,@(loop
 			 :for i :from 1 :to *class-number*
 			 :collect
-			 (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)))
+			 (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 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
+				(jvm::emit 'jvm::checkcast +fasl-classloader+)
 				(jvm::emit 'jvm::dup)
 				(jvm::emit-push-constant-int ,(1- i))
-				(jvm::emit 'jvm::new ,class)
+				(jvm::emit 'jvm::new ,class-name)
 				(jvm::emit 'jvm::dup)
-				(jvm::emit-invokespecial-init ,class '())
-				(jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
+				(jvm::emit-invokespecial-init ,class-name '())
+				(jvm::emit-invokevirtual +fasl-classloader+
+                                                         "putFunction"
 							 (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
 				(jvm::emit 'jvm::pop))
 			      t))))))



From ehuelsmann at common-lisp.net  Mon Aug  2 10:51:31 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 02 Aug 2010 06:51:31 -0400
Subject: [armedbear-cvs] r12853 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OfscE-0007LJ-Gn@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  2 06:51:28 2010
New Revision: 12853

Log:
Convert DECLARE-LOCAL-FUNCTION and DUPLICATE-CLOSURE-ARRAY
to use CLASS-NAMEs instead of literal strings.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  2 06:51:28 2010
@@ -2251,9 +2251,9 @@
   (declare-with-hashtable
    local-function *declared-functions* ht g
    (setf g (symbol-name (gensym "LFUN")))
-   (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function)))
-	  (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname)))
-	  (*code* *static-code*))
+   (let* ((class-name (abcl-class-file-class
+                       (local-function-class-file local-function)))
+          (*code* *static-code*))
      ;; fixme *declare-inline*
      (declare-field g +lisp-object+ +field-access-private+)
      (emit 'new class-name)
@@ -3010,7 +3010,7 @@
     (astore register)  ;; save dest value
     (emit-push-constant-int 0)                            ;; destPos
     (emit-push-constant-int (length *closure-variables*)) ;; length
-    (emit-invokestatic "java/lang/System" "arraycopy"
+    (emit-invokestatic +java-system+ "arraycopy"
                        (list +java-object+ "I"
                              +java-object+ "I" "I") nil)
     (aload register))) ;; reload dest value

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Mon Aug  2 06:51:28 2010
@@ -132,6 +132,7 @@
 
 (define-class-name +java-object+ "java.lang.Object")
 (define-class-name +java-string+ "java.lang.String")
+(define-class-name +java-system+ "java.lang.System")
 (define-class-name +lisp-object+ "org.armedbear.lisp.LispObject")
 (defconstant +lisp-object-array+ (class-array +lisp-object+))
 (define-class-name +lisp-simple-string+ "org.armedbear.lisp.SimpleString")



From ehuelsmann at common-lisp.net  Mon Aug  2 11:03:41 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 02 Aug 2010 07:03:41 -0400
Subject: [armedbear-cvs] r12854 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ofso1-0000w0-04@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  2 07:03:40 2010
New Revision: 12854

Log:
Convert known-symbols.lisp to CLASS-NAMEs.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/known-symbols.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Mon Aug  2 07:03:40 2010
@@ -42,10 +42,10 @@
   (require "COMPILER-TYPES")
   (require "COMPILER-ERROR")
   (require "KNOWN-FUNCTIONS")
-  (require "KNOWN-SYMBOLS")
   (require "DUMP-FORM")
   (require "OPCODES")
   (require "JVM-CLASS-FILE")
+  (require "KNOWN-SYMBOLS")
   (require "JAVA")
   (require "COMPILER-PASS1")
   (require "COMPILER-PASS2"))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/known-symbols.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/known-symbols.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/known-symbols.lisp	Mon Aug  2 07:03:40 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 (substitute #\/ #\. source))
+           (class-designator (jvm::make-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  Mon Aug  2 11:33:40 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 02 Aug 2010 07:33:40 -0400
Subject: [armedbear-cvs] r12855 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OftH1-0004YC-Vj@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  2 07:33:39 2010
New Revision: 12855

Log:
Start removing CLASS-NAME dual-mode-compatible shim code:
remove !CLASS-NAME.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  2 07:33:39 2010
@@ -99,7 +99,7 @@
 (declaim (inline pool-class))
 (defun pool-class (class-name)
   (declare (optimize speed))
-  (pool-get (list 7 (pool-name class-name))))
+  (pool-get (list 7 (pool-name (class-name-internal class-name)))))
 
 ;; (tag class-index name-and-type-index)
 (declaim (ftype (function (string string string) fixnum) pool-field))
@@ -206,18 +206,11 @@
                           :code handler
                           :catch-type (if (null type)
                                           0
-                                          (pool-class (!class-name type))))
+                                          (pool-class type)))
             *handlers*)
       (code-add-exception-handler *current-code-attribute*
                                   start end handler type)))
 
-(defun !class-name (class-name)
-  "To be eliminated when all hard-coded strings are replaced by `class-name'
-structures"
-  (if (typep class-name 'class-name)
-      (class-name-internal class-name)
-      class-name))
-
 (defun !class-ref (class-name)
   "To be eliminated when all hard-coded strings are
 replaced by `class-name' structures"
@@ -461,7 +454,7 @@
          (descriptor (car info))
          (stack-effect (cdr info))
          (index (if (null *current-code-attribute*)
-                    (pool-method (!class-name class-name) method-name descriptor)
+                    (pool-method class-name method-name descriptor)
                     (pool-add-method-ref *pool* class-name
                                          method-name (cons return-type arg-types))))
          (instruction (apply #'%emit 'invokestatic (u2 index))))
@@ -471,7 +464,7 @@
 
 (declaim (ftype (function t string) pretty-java-class))
 (defun pretty-java-class (class)
-  (cond ((equal (!class-name class) (!class-name +lisp-object+))
+  (cond ((equal class +lisp-object+)
          "LispObject")
         ((equal class +lisp-symbol+)
          "Symbol")
@@ -486,7 +479,7 @@
          (descriptor (car info))
          (stack-effect (cdr info))
          (index (if (null *current-code-attribute*)
-                    (pool-method (!class-name class-name) method-name descriptor)
+                    (pool-method class-name method-name descriptor)
                     (pool-add-method-ref *pool* class-name
                                          method-name (cons return-type arg-types))))
          (instruction (apply #'%emit 'invokevirtual (u2 index))))
@@ -507,7 +500,7 @@
          (descriptor (car info))
          (stack-effect (cdr info))
          (index (if (null *current-code-attribute*)
-                    (pool-method (!class-name  class-name) "<init>" descriptor)
+                    (pool-method class-name "<init>" descriptor)
                     (pool-add-method-ref *pool* class-name
                                          "<init>" (cons nil arg-types))))
          (instruction (apply #'%emit 'invokespecial (u2 index))))
@@ -549,16 +542,14 @@
 (defknown emit-getstatic (t t t) t)
 (defun emit-getstatic (class-name field-name type)
   (let ((index (if (null *current-code-attribute*)
-                   (pool-field (!class-name class-name)
-                           field-name (!class-ref type))
+                   (pool-field class-name field-name (!class-ref type))
                    (pool-add-field-ref *pool* class-name field-name type))))
     (apply #'%emit 'getstatic (u2 index))))
 
 (defknown emit-putstatic (t t t) t)
 (defun emit-putstatic (class-name field-name type)
   (let ((index (if (null *current-code-attribute*)
-                   (pool-field (!class-name class-name)
-                           field-name (!class-ref type))
+                   (pool-field class-name field-name (!class-ref type))
                    (pool-add-field-ref *pool* class-name field-name type))))
     (apply #'%emit 'putstatic (u2 index))))
 
@@ -1227,14 +1218,14 @@
 ;; getfield, putfield class-name field-name type-name
 (define-resolver (180 181) (instruction)
   (let* ((args (instruction-args instruction))
-         (index (pool-field (!class-name (first args))
+         (index (pool-field (first args)
                             (second args) (!class-ref (third args)))))
     (inst (instruction-opcode instruction) (u2 index))))
 
 ;; new, anewarray, checkcast, instanceof class-name
 (define-resolver (187 189 192 193) (instruction)
   (let* ((args (instruction-args instruction))
-         (index (pool-class (!class-name (first args)))))
+         (index (pool-class (first args))))
     (inst (instruction-opcode instruction) (u2 index))))
 
 ;; iinc
@@ -7876,8 +7867,8 @@
 (defun write-class-file (class-file stream)
   (let* ((super (abcl-class-file-superclass class-file))
          (this (abcl-class-file-class class-file))
-         (this-index (pool-class (!class-name this)))
-         (super-index (pool-class (!class-name super)))
+         (this-index (pool-class this))
+         (super-index (pool-class super))
          (constructor (make-constructor super
                                         (abcl-class-file-lambda-name class-file)
                                         (abcl-class-file-lambda-list class-file))))



From ehuelsmann at common-lisp.net  Mon Aug  2 20:59:55 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 02 Aug 2010 16:59:55 -0400
Subject: [armedbear-cvs] r12856 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Og271-0000WG-BH@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  2 16:59:52 2010
New Revision: 12856

Log:
Change all literal strings for argument type identification (ie. "I")
to keyword symbols for readability (ie :int) and jvm-class-file
compatibility.

Note: This commit also removes the descriptor cache/hash. If there's
no other way, we can add it back for performance reasons, but I'd
rather put the burden of caching descriptors on the callers.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp	Mon Aug  2 16:59:52 2010
@@ -699,7 +699,7 @@
 				(jvm::emit-invokespecial-init ,class-name '())
 				(jvm::emit-invokevirtual +fasl-classloader+
                                                          "putFunction"
-							 (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
+							 (list :int jvm::+lisp-object+) jvm::+lisp-object+)
 				(jvm::emit 'jvm::pop))
 			      t))))))
 	 (classname (fasl-loader-classname))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  2 16:59:52 2010
@@ -214,8 +214,8 @@
 (defun !class-ref (class-name)
   "To be eliminated when all hard-coded strings are
 replaced by `class-name' structures"
-  (if (typep class-name 'class-name)
-      (class-ref class-name)
+  (if (or (symbolp class-name) (typep class-name 'class-name))
+      (internal-field-ref class-name)
       class-name))
 
 (defstruct (instruction (:constructor %make-instruction (opcode args)))
@@ -412,47 +412,14 @@
            (emit 'dup2_x2)
            (emit 'pop2)))))
 
-(declaim (ftype (function (t t) cons) make-descriptor-info))
-(defun make-descriptor-info (arg-types return-type)
-  (let ((descriptor (with-standard-io-syntax
-                      (with-output-to-string (s)
-                        (princ #\( s)
-                        (dolist (type arg-types)
-                          (princ type s))
-                        (princ #\) s)
-                        (princ (or return-type "V") s))))
-        (stack-effect (let ((result (cond ((null return-type) 0)
-                                          ((or (equal return-type "J")
-                                               (equal return-type "D")) 2)
-                                          (t 1))))
-                        (dolist (type arg-types result)
-                          (decf result (if (or (equal type "J")
-                                               (equal type "D"))
-                                           2 1))))))
-    (cons descriptor stack-effect)))
-
-(defparameter *descriptors* (make-hash-table :test #'equal))
-
-(declaim (ftype (function (t t) cons) get-descriptor-info))
-(defun get-descriptor-info (arg-types return-type)
-  (let* ((arg-types (mapcar #'!class-ref arg-types))
-         (return-type (!class-ref return-type))
-         (key (list arg-types return-type))
-         (ht *descriptors*)
-         (descriptor-info (gethash1 key ht)))
-    (declare (type hash-table ht))
-    (or descriptor-info
-        (setf (gethash key ht) (make-descriptor-info arg-types return-type)))))
-
 (declaim (inline get-descriptor))
 (defun get-descriptor (arg-types return-type)
-  (car (get-descriptor-info arg-types return-type)))
+  (apply #'descriptor return-type arg-types))
 
 (declaim (ftype (function * t) emit-invokestatic))
 (defun emit-invokestatic (class-name method-name arg-types return-type)
-  (let* ((info (get-descriptor-info arg-types return-type))
-         (descriptor (car info))
-         (stack-effect (cdr info))
+  (let* ((descriptor (apply #'descriptor return-type arg-types))
+         (stack-effect (apply #'descriptor-stack-effect return-type arg-types))
          (index (if (null *current-code-attribute*)
                     (pool-method class-name method-name descriptor)
                     (pool-add-method-ref *pool* class-name
@@ -475,9 +442,8 @@
 
 (defknown emit-invokevirtual (t t t t) t)
 (defun emit-invokevirtual (class-name method-name arg-types return-type)
-  (let* ((info (get-descriptor-info arg-types return-type))
-         (descriptor (car info))
-         (stack-effect (cdr info))
+  (let* ((descriptor (apply #'descriptor return-type arg-types))
+         (stack-effect (apply #'descriptor-stack-effect return-type arg-types))
          (index (if (null *current-code-attribute*)
                     (pool-method class-name method-name descriptor)
                     (pool-add-method-ref *pool* class-name
@@ -496,9 +462,8 @@
 
 (defknown emit-invokespecial-init (string list) t)
 (defun emit-invokespecial-init (class-name arg-types)
-  (let* ((info (get-descriptor-info arg-types nil))
-         (descriptor (car info))
-         (stack-effect (cdr info))
+  (let* ((descriptor (apply #'descriptor :void arg-types))
+         (stack-effect (apply #'descriptor-stack-effect :void arg-types))
          (index (if (null *current-code-attribute*)
                     (pool-method class-name "<init>" descriptor)
                     (pool-add-method-ref *pool* class-name
@@ -524,13 +489,14 @@
                  "Symbol")
                 ((equal type +lisp-thread+)
                  "LispThread")
-                ((equal type "C")
+                ((equal type :char)
                  "char")
-                ((equal type "I")
+                ((equal type :int)
                  "int")
-                ((equal type "Z")
+                ((equal type :boolean)
                  "boolean")
-                ((null type)
+                ((or (null type)
+                     (eq type :void))
                  "void")
                 (t
                  type)))
@@ -593,10 +559,10 @@
 (defun emit-unbox-character ()
   (cond ((> *safety* 0)
          (emit-invokestatic +lisp-character+ "getValue"
-                            (lisp-object-arg-types 1) "C"))
+                            (lisp-object-arg-types 1) :char))
         (t
          (emit 'checkcast +lisp-character+)
-         (emit 'getfield +lisp-character+ "value" "C"))))
+         (emit 'getfield +lisp-character+ "value" :char))))
 
 ;;                     source type /
 ;;                         targets   :boolean :char    :int :long :float :double
@@ -623,15 +589,6 @@
   "Lists the class on which to call the `getInstance' method on,
 when converting the internal representation to a LispObject.")
 
-(defvar rep-arg-chars
-  '((:boolean . "Z")
-    (:char    . "C")
-    (:int     . "I")
-    (:long    . "J")
-    (:float   . "F")
-    (:double  . "D"))
-  "Lists the argument type identifiers for each
-of the internal representations.")
 
 (defun convert-representation (in out)
   "Converts the value on the stack in the `in' representation
@@ -642,10 +599,8 @@
   (when (null out)
     ;; Convert back to a lisp object
     (when in
-      (let ((class (cdr (assoc in rep-classes)))
-            (arg-spec (cdr (assoc in rep-arg-chars))))
-        (emit-invokestatic class "getInstance" (list arg-spec)
-                           class)))
+      (let ((class (cdr (assoc in rep-classes))))
+        (emit-invokestatic class "getInstance" (list in) class)))
     (return-from convert-representation))
   (let* ((in-map (cdr (assoc in rep-conversion)))
          (op-num (position out '(:boolean :char :int :long :float :double)))
@@ -659,8 +614,7 @@
             ((functionp op)
              (funcall op))
             ((stringp op)
-             (emit-invokevirtual +lisp-object+ op nil
-                                 (cdr (assoc out rep-arg-chars))))
+             (emit-invokevirtual +lisp-object+ op nil out))
             (t
              (emit op))))))
 
@@ -815,7 +769,7 @@
 (defun maybe-generate-interrupt-check ()
   (unless (> *speed* *safety*)
     (let ((label1 (gensym)))
-      (emit-getstatic +lisp+ "interrupted" "Z")
+      (emit-getstatic +lisp+ "interrupted" :boolean)
       (emit 'ifeq label1)
       (emit-invokestatic +lisp+ "handleInterrupt" nil nil)
       (label label1))))
@@ -894,35 +848,35 @@
   (declare (optimize speed))
   (cond ((= *safety* 3)
          (emit-invokestatic +lisp-fixnum+ "getValue"
-                            (lisp-object-arg-types 1) "I"))
+                            (lisp-object-arg-types 1) :int))
         (t
          (emit 'checkcast +lisp-fixnum+)
-         (emit 'getfield +lisp-fixnum+ "value" "I"))))
+         (emit 'getfield +lisp-fixnum+ "value" :int))))
 
 (defknown emit-unbox-long () t)
 (defun emit-unbox-long ()
   (emit-invokestatic +lisp-bignum+ "longValue"
-                     (lisp-object-arg-types 1) "J"))
+                     (lisp-object-arg-types 1) :long))
 
 (defknown emit-unbox-float () t)
 (defun emit-unbox-float ()
   (declare (optimize speed))
   (cond ((= *safety* 3)
          (emit-invokestatic +lisp-single-float+ "getValue"
-                            (lisp-object-arg-types 1) "F"))
+                            (lisp-object-arg-types 1) :float))
         (t
          (emit 'checkcast +lisp-single-float+)
-         (emit 'getfield +lisp-single-float+ "value" "F"))))
+         (emit 'getfield +lisp-single-float+ "value" :float))))
 
 (defknown emit-unbox-double () t)
 (defun emit-unbox-double ()
   (declare (optimize speed))
   (cond ((= *safety* 3)
          (emit-invokestatic +lisp-double-float+ "getValue"
-                            (lisp-object-arg-types 1) "D"))
+                            (lisp-object-arg-types 1) :double))
         (t
          (emit 'checkcast +lisp-double-float+)
-         (emit 'getfield +lisp-double-float+ "value" "D"))))
+         (emit 'getfield +lisp-double-float+ "value" :double))))
 
 (defknown fix-boxing (t t) t)
 (defun fix-boxing (required-representation derived-type)
@@ -933,19 +887,19 @@
          (cond ((and (fixnum-type-p derived-type)
                      (< *safety* 3))
                 (emit 'checkcast +lisp-fixnum+)
-                (emit 'getfield +lisp-fixnum+ "value" "I"))
+                (emit 'getfield +lisp-fixnum+ "value" :int))
                (t
-                (emit-invokevirtual +lisp-object+ "intValue" nil "I"))))
+                (emit-invokevirtual +lisp-object+ "intValue" nil :int))))
         ((eq required-representation :char)
          (emit-unbox-character))
         ((eq required-representation :boolean)
          (emit-unbox-boolean))
         ((eq required-representation :long)
-         (emit-invokevirtual +lisp-object+ "longValue" nil "J"))
+         (emit-invokevirtual +lisp-object+ "longValue" nil :long))
         ((eq required-representation :float)
-         (emit-invokevirtual +lisp-object+ "floatValue" nil "F"))
+         (emit-invokevirtual +lisp-object+ "floatValue" nil :float))
         ((eq required-representation :double)
-         (emit-invokevirtual +lisp-object+ "doubleValue" nil "D"))
+         (emit-invokevirtual +lisp-object+ "doubleValue" nil :double))
         (t (assert nil))))
 
 (defknown emit-move-from-stack (t &optional t) t)
@@ -1820,10 +1774,10 @@
              (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" "I")
+             (emit-getstatic +lisp-closure+ "OPTIONAL" :int)
              (emit-invokespecial-init +lisp-closure-parameter+
                                       (list +lisp-symbol+ +lisp-object+
-                                            +lisp-object+ "I")))
+                                            +lisp-object+ :int)))
 
           (parameters-to-array (param key key-params-register)
              (let ((keyword (fourth param)))
@@ -2024,23 +1978,23 @@
        ((<= most-negative-fixnum n most-positive-fixnum)
         (emit-push-constant-int n)
         (emit-invokestatic +lisp-fixnum+ "getInstance"
-                           '("I") +lisp-fixnum+))
+                           '(:int) +lisp-fixnum+))
        ((<= most-negative-java-long n most-positive-java-long)
         (emit-push-constant-long n)
         (emit-invokestatic +lisp-bignum+ "getInstance"
-                           '("J") +lisp-integer+))
+                           '(:long) +lisp-integer+))
        (t
         (let* ((*print-base* 10)
                (s (with-output-to-string (stream) (dump-form n stream))))
           (emit 'ldc (pool-string s))
           (emit-push-constant-int 10)
           (emit-invokestatic +lisp-bignum+ "getInstance"
-                             (list +java-string+ "I") +lisp-integer+)))))
+                             (list +java-string+ :int) +lisp-integer+)))))
 
 (defun serialize-character (c)
   "Generates code to restore a serialized character."
   (emit-push-constant-int (char-code c))
-  (emit-invokestatic +lisp-character+ "getInstance" '("C")
+  (emit-invokestatic +lisp-character+ "getInstance" '(:char)
                      +lisp-character+))
 
 (defun serialize-float (s)
@@ -2048,14 +2002,14 @@
   (emit 'new +lisp-single-float+)
   (emit 'dup)
   (emit 'ldc (pool-float s))
-  (emit-invokespecial-init +lisp-single-float+ '("F")))
+  (emit-invokespecial-init +lisp-single-float+ '(:float)))
 
 (defun serialize-double (d)
   "Generates code to restore a serialized double-float."
   (emit 'new +lisp-double-float+)
   (emit 'dup)
   (emit 'ldc2_w (pool-double d))
-  (emit-invokespecial-init +lisp-double-float+ '("D")))
+  (emit-invokespecial-init +lisp-double-float+ '(:double)))
 
 (defun serialize-string (string)
   "Generate code to restore a serialized string."
@@ -2090,7 +2044,7 @@
        (emit-getstatic class name +lisp-symbol+))
       ((null (symbol-package symbol))
        (emit-push-constant-int (dump-uninterned-symbol-index symbol))
-       (emit-invokestatic +lisp-load+ "getUninternedSymbol" '("I")
+       (emit-invokestatic +lisp-load+ "getUninternedSymbol" '(:int)
                           +lisp-object+)
        (emit 'checkcast +lisp-symbol+))
       ((keywordp symbol)
@@ -2333,7 +2287,7 @@
             (emit-push-constant-int form))
            ((integerp form)
             (emit-load-externalized-object form)
-            (emit-invokevirtual +lisp-object+ "intValue" nil "I"))
+            (emit-invokevirtual +lisp-object+ "intValue" nil :int))
            (t
             (sys::%format t "compile-constant int representation~%")
             (assert nil)))
@@ -2344,7 +2298,7 @@
             (emit-push-constant-long form))
            ((integerp form)
             (emit-load-externalized-object form)
-            (emit-invokevirtual +lisp-object+ "longValue" nil "J"))
+            (emit-invokevirtual +lisp-object+ "longValue" nil :long))
            (t
             (sys::%format t "compile-constant long representation~%")
             (assert nil)))
@@ -2472,7 +2426,7 @@
                (:boolean
                 (emit-invokevirtual +lisp-object+
                                     unboxed-method-name
-                                    nil "Z"))
+                                    nil :boolean))
                ((NIL)
                 (emit-invokevirtual +lisp-object+
                                     boxed-method-name
@@ -2607,7 +2561,7 @@
    t)
 
 (defun emit-ifne-for-eql (representation instruction-type)
-  (emit-invokevirtual +lisp-object+ "eql" instruction-type "Z")
+  (emit-invokevirtual +lisp-object+ "eql" instruction-type :boolean)
   (convert-representation :boolean representation))
 
 (defknown p2-eql (t t t) t)
@@ -2633,28 +2587,28 @@
           ((fixnum-type-p type2)
 	   (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 						      arg2 'stack :int)
-	   (emit-ifne-for-eql representation '("I")))
+	   (emit-ifne-for-eql representation '(:int)))
           ((fixnum-type-p type1)
 	   (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 						      arg2 'stack nil)
            (emit 'swap)
-	   (emit-ifne-for-eql representation '("I")))
+	   (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 '("C")))
+	   (emit-ifne-for-eql representation '(:char)))
           ((eq type1 'CHARACTER)
 	   (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
 						      arg2 'stack nil)
            (emit 'swap)
-	   (emit-ifne-for-eql representation '("C")))
+	   (emit-ifne-for-eql representation '(:char)))
           (t
 	   (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 						      arg2 'stack nil)
            (ecase representation
              (:boolean
               (emit-invokevirtual +lisp-object+ "eql"
-                                  (lisp-object-arg-types 1) "Z"))
+                                  (lisp-object-arg-types 1) :boolean))
              ((NIL)
               (emit-invokevirtual +lisp-object+ "EQL"
                                   (lisp-object-arg-types 1) +lisp-object+)))))
@@ -2670,7 +2624,7 @@
            (compile-form arg1 'stack nil)
            (compile-form arg2 'stack nil)
            (emit-invokestatic +lisp+ "memq"
-                              (lisp-object-arg-types 2) "Z")
+                              (lisp-object-arg-types 2) :boolean)
            (emit-move-from-stack target representation)))
         (t
          (compile-function-call form target representation))))
@@ -2687,10 +2641,10 @@
            (compile-form arg2 'stack nil)
            (cond ((eq type1 'SYMBOL) ; FIXME
                   (emit-invokestatic +lisp+ "memq"
-                                     (lisp-object-arg-types 2) "Z"))
+                                     (lisp-object-arg-types 2) :boolean))
                  (t
                   (emit-invokestatic +lisp+ "memql"
-                                     (lisp-object-arg-types 2) "Z")))
+                                     (lisp-object-arg-types 2) :boolean)))
            (emit-move-from-stack target representation)))
         (t
          (compile-function-call form target representation))))
@@ -3002,8 +2956,8 @@
     (emit-push-constant-int 0)                            ;; destPos
     (emit-push-constant-int (length *closure-variables*)) ;; length
     (emit-invokestatic +java-system+ "arraycopy"
-                       (list +java-object+ "I"
-                             +java-object+ "I" "I") nil)
+                       (list +java-object+ :int
+                             +java-object+ :int :int) nil)
     (aload register))) ;; reload dest value
 
 
@@ -3126,8 +3080,8 @@
                                       (>  "isGreaterThan")
                                       (>= "isGreaterThanOrEqualTo")
                                       (=  "isEqualTo"))
-                                    '("I")
-                                    "Z")
+                                    '(:int)
+                                    :boolean)
                 ;; Java boolean on stack here
                 (convert-representation :boolean representation)
                 (emit-move-from-stack target representation)
@@ -3252,7 +3206,7 @@
   (when (check-arg-count form 1)
     (let ((arg (%cadr form)))
       (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
-      (emit-invokevirtual +lisp-object+ java-predicate nil "Z")
+      (emit-invokevirtual +lisp-object+ java-predicate nil :boolean)
       'ifeq)))
 
 (declaim (ftype (function (t t) t) p2-test-instanceof-predicate))
@@ -3274,7 +3228,7 @@
   (when (= (length form) 2)
     (let ((arg (%cadr form)))
       (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
-      (emit-invokevirtual +lisp-object+ "constantp" nil "Z")
+      (emit-invokevirtual +lisp-object+ "constantp" nil :boolean)
       'ifeq)))
 
 (defun p2-test-endp (form)
@@ -3465,30 +3419,30 @@
             ((eq type2 'CHARACTER)
 	     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							arg2 'stack :char)
-             (emit-invokevirtual +lisp-object+ "eql" '("C") "Z")
+             (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
              'ifeq)
             ((eq type1 'CHARACTER)
 	     (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
 							arg2 'stack nil)
              (emit 'swap)
-             (emit-invokevirtual +lisp-object+ "eql" '("C") "Z")
+             (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)
-             (emit-invokevirtual +lisp-object+ "eql" '("I") "Z")
+             (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)
              (emit 'swap)
-             (emit-invokevirtual +lisp-object+ "eql" '("I") "Z")
+             (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
              'ifeq)
             (t
 	     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							arg2 'stack nil)
              (emit-invokevirtual +lisp-object+ "eql"
-                                 (lisp-object-arg-types 1) "Z")
+                                 (lisp-object-arg-types 1) :boolean)
              'ifeq)))))
 
 (defun p2-test-equality (form)
@@ -3504,13 +3458,13 @@
 							arg2 'stack :int)
              (emit-invokevirtual +lisp-object+
                                  translated-op
-                                 '("I") "Z"))
+                                 '(:int) :boolean))
             (t
 	     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							arg2 'stack nil)
              (emit-invokevirtual +lisp-object+
                                  translated-op
-                                 (lisp-object-arg-types 1) "Z")))
+                                 (lisp-object-arg-types 1) :boolean)))
       'ifeq)))
 
 (defun p2-test-simple-typep (form)
@@ -3531,7 +3485,7 @@
       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 						 arg2 'stack nil)
       (emit-invokestatic +lisp+ "memq"
-                         (lisp-object-arg-types 2) "Z")
+                         (lisp-object-arg-types 2) :boolean)
       'ifeq)))
 
 (defun p2-test-memql (form)
@@ -3541,7 +3495,7 @@
       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 						 arg2 'stack nil)
       (emit-invokestatic +lisp+ "memql"
-                         (lisp-object-arg-types 2) "Z")
+                         (lisp-object-arg-types 2) :boolean)
       'ifeq)))
 
 (defun p2-test-/= (form)
@@ -3560,7 +3514,7 @@
             ((fixnum-type-p type2)
 	     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							arg2 'stack :int)
-             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '("I") "Z")
+             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
              'ifeq)
             ((fixnum-type-p type1)
              ;; FIXME Compile the args in reverse order and avoid the swap if
@@ -3568,13 +3522,13 @@
 	     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 							arg2 'stack nil)
              (emit 'swap)
-             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '("I") "Z")
+             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
              'ifeq)
             (t
 	     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							arg2 'stack nil)
              (emit-invokevirtual +lisp-object+ "isNotEqualTo"
-                                 (lisp-object-arg-types 1) "Z")
+                                 (lisp-object-arg-types 1) :boolean)
              'ifeq)))))
 
 (defun p2-test-numeric-comparison (form)
@@ -3617,7 +3571,7 @@
                                      (>  "isGreaterThan")
                                      (>= "isGreaterThanOrEqualTo")
                                      (=  "isEqualTo"))
-                                   '("I") "Z")
+                                   '(:int) :boolean)
                'ifeq)
               ((fixnum-type-p type1)
                ;; FIXME We can compile the args in reverse order and avoid
@@ -3632,7 +3586,7 @@
                                      (>  "isLessThan")
                                      (>= "isLessThanOrEqualTo")
                                      (=  "isEqualTo"))
-                                   '("I") "Z")
+                                   '(:int) :boolean)
                'ifeq)
               (t
 	       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
@@ -3644,7 +3598,7 @@
                                      (>  "isGreaterThan")
                                      (>= "isGreaterThanOrEqualTo")
                                      (=  "isEqualTo"))
-                                   (lisp-object-arg-types 1) "Z")
+                                   (lisp-object-arg-types 1) :boolean)
                'ifeq))))))
 
 (defknown p2-if-or (t t t) t)
@@ -4021,7 +3975,7 @@
              (aload result-register)
              (emit-push-constant-int (length vars))
              (emit-invokevirtual +lisp-thread+ "getValues"
-                                 (list +lisp-object+ "I") +lisp-object-array+)
+                                 (list +lisp-object+ :int) +lisp-object-array+)
              ;; Values array is now on the stack at runtime.
              (label LABEL2)
              (let ((index 0))
@@ -5156,7 +5110,7 @@
                  (t
 		  (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							     arg2 'stack :int)
-                  (emit-invokevirtual +lisp-object+ "ash" '("I") +lisp-object+)
+                  (emit-invokevirtual +lisp-object+ "ash" '(:int) +lisp-object+)
                   (fix-boxing representation result-type)))
            (emit-move-from-stack target representation))
           (t
@@ -5220,7 +5174,7 @@
                ((fixnum-type-p type2)
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							   arg2 'stack :int)
-                (emit-invokevirtual +lisp-object+ "LOGAND" '("I") +lisp-object+)
+                (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+)
                 (fix-boxing representation result-type)
                 (emit-move-from-stack target representation))
                ((fixnum-type-p type1)
@@ -5229,7 +5183,7 @@
 							   arg2 'stack nil)
                 ;; swap args
                 (emit 'swap)
-                (emit-invokevirtual +lisp-object+ "LOGAND" '("I") +lisp-object+)
+                (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+)
                 (fix-boxing representation result-type)
                 (emit-move-from-stack target representation))
                (t
@@ -5292,7 +5246,7 @@
                ((fixnum-type-p type2)
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							   arg2 'stack :int)
-                (emit-invokevirtual +lisp-object+ "LOGIOR" '("I") +lisp-object+)
+                (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+)
                 (fix-boxing representation result-type)
                 (emit-move-from-stack target representation))
                ((fixnum-type-p type1)
@@ -5301,7 +5255,7 @@
 							   arg2 'stack nil)
                 ;; swap args
                 (emit 'swap)
-                (emit-invokevirtual +lisp-object+ "LOGIOR" '("I") +lisp-object+)
+                (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+)
                 (fix-boxing representation result-type)
                 (emit-move-from-stack target representation))
                (t
@@ -5356,7 +5310,7 @@
                ((fixnum-type-p type2)
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							   arg2 'stack :int)
-                (emit-invokevirtual +lisp-object+ "LOGXOR" '("I") +lisp-object+)
+                (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+)
                 (fix-boxing representation result-type))
                (t
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack nil
@@ -5440,7 +5394,7 @@
 		  (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" '("I" "I") +lisp-object+)
+                  (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+)
                   (fix-boxing representation nil)
                   (emit-move-from-stack target representation))))
           ((and (fixnum-type-p size-type)
@@ -5450,7 +5404,7 @@
 						      arg3 'stack nil)
            (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved
            (emit 'pop)
-           (emit-invokevirtual +lisp-object+ "LDB" '("I" "I") +lisp-object+)
+           (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+)
            (fix-boxing representation nil)
            (emit-move-from-stack target representation))
           (t
@@ -5469,12 +5423,12 @@
                 (fixnum-type-p type2))
 	   (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 						      arg2 'stack :int)
-           (emit-invokestatic +lisp+ "mod" '("I" "I") "I")
+           (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)
-           (emit-invokevirtual +lisp-object+ "MOD" '("I") +lisp-object+)
+           (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+)
            (fix-boxing representation nil) ; FIXME use derived result type
            (emit-move-from-stack target representation))
           (t
@@ -5549,7 +5503,7 @@
        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
        (emit-push-constant-int 1) ; errorp
        (emit-invokestatic +lisp-class+ "findClass"
-                          (list +lisp-object+ "Z") +lisp-object+)
+                          (list +lisp-object+ :boolean) +lisp-object+)
        (fix-boxing representation nil)
        (emit-move-from-stack target representation))
       (2
@@ -5557,7 +5511,7 @@
 	 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 						    arg2 'stack :boolean)
          (emit-invokestatic +lisp-class+ "findClass"
-                            (list +lisp-object+ "Z") +lisp-object+)
+                            (list +lisp-object+ :boolean) +lisp-object+)
          (fix-boxing representation nil)
          (emit-move-from-stack target representation)))
       (t
@@ -5632,7 +5586,7 @@
            (emit 'new +lisp-simple-vector+)
            (emit 'dup)
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
-           (emit-invokespecial-init +lisp-simple-vector+ '("I"))
+           (emit-invokespecial-init +lisp-simple-vector+ '(:int))
            (emit-move-from-stack target representation)))
         (t
          (compile-function-call form target representation))))
@@ -5661,7 +5615,7 @@
           (emit 'new class)
           (emit 'dup)
 	  (compile-forms-and-maybe-emit-clear-values arg2 'stack :int)
-          (emit-invokespecial-init class '("I"))
+          (emit-invokespecial-init class '(:int))
           (emit-move-from-stack target representation)
           (return-from p2-make-sequence)))))
   (compile-function-call form target representation))
@@ -5676,7 +5630,7 @@
            (emit 'new +lisp-simple-string+)
            (emit 'dup)
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
-           (emit-invokespecial-init +lisp-simple-string+ '("I"))
+           (emit-invokespecial-init +lisp-simple-string+ '(:int))
            (emit-move-from-stack target representation)))
         (t
          (compile-function-call form target representation))))
@@ -5756,7 +5710,7 @@
            (emit 'checkcast +lisp-stream+)
            (maybe-emit-clear-values arg1 arg2)
            (emit 'swap)
-           (emit-invokevirtual +lisp-stream+ "_writeByte" '("I") nil)
+           (emit-invokevirtual +lisp-stream+ "_writeByte" '(:int) nil)
            (when target
              (emit-push-nil)
              (emit-move-from-stack target)))
@@ -5765,7 +5719,7 @@
            (compile-form arg2 'stack nil)
            (maybe-emit-clear-values arg1 arg2)
            (emit-invokestatic +lisp+ "writeByte"
-                              (list "I" +lisp-object+) nil)
+                              (list :int +lisp-object+) nil)
            (when target
              (emit-push-nil)
              (emit-move-from-stack target)))
@@ -5785,7 +5739,7 @@
                 (emit-push-constant-int 1)
                 (emit-push-nil)
                 (emit-invokevirtual +lisp-stream+ "readLine"
-                                    (list "Z" +lisp-object+) +lisp-object+)
+                                    (list :boolean +lisp-object+) +lisp-object+)
                 (emit-move-from-stack target))
                (t
                 (compile-function-call form target representation)))))
@@ -5799,7 +5753,7 @@
                 (emit-push-constant-int 0)
                 (emit-push-nil)
                 (emit-invokevirtual +lisp-stream+ "readLine"
-                                    (list "Z" +lisp-object+) +lisp-object+)
+                                    (list :boolean +lisp-object+) +lisp-object+)
                 (emit-move-from-stack target)
                 )
                (t
@@ -6362,13 +6316,13 @@
     (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     (ecase representation
       (:int
-       (emit-invokevirtual +lisp-object+ "length" nil "I"))
+       (emit-invokevirtual +lisp-object+ "length" nil :int))
       ((:long :float :double)
-       (emit-invokevirtual +lisp-object+ "length" nil "I")
+       (emit-invokevirtual +lisp-object+ "length" nil :int)
        (convert-representation :int representation))
       (:boolean
        ;; FIXME We could optimize this all away in unsafe calls.
-       (emit-invokevirtual +lisp-object+ "length" nil "I")
+       (emit-invokevirtual +lisp-object+ "length" nil :int)
        (emit 'pop)
        (emit 'iconst_1))
       (:char
@@ -6425,7 +6379,7 @@
     (compile-forms-and-maybe-emit-clear-values index-form 'stack :int
 					       list-form 'stack nil)
     (emit 'swap)
-    (emit-invokevirtual +lisp-object+ "NTH" '("I") +lisp-object+)
+    (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+)
     (fix-boxing representation nil) ; FIXME use derived result type
     (emit-move-from-stack target representation)))
 
@@ -6464,7 +6418,7 @@
              ((fixnump arg2)
 	      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
               (emit-push-int arg2)
-              (emit-invokevirtual +lisp-object+ "multiplyBy" '("I") +lisp-object+)
+              (emit-invokevirtual +lisp-object+ "multiplyBy" '(:int) +lisp-object+)
               (fix-boxing representation result-type)
               (emit-move-from-stack target representation))
              (t
@@ -6518,7 +6472,7 @@
                                       (if (eq op 'max)
                                           "isLessThanOrEqualTo"
                                           "isGreaterThanOrEqualTo")
-                                      (lisp-object-arg-types 1) "Z")
+                                      (lisp-object-arg-types 1) :boolean)
                   (let ((LABEL1 (gensym)))
                     (emit 'ifeq LABEL1)
                     (emit 'swap)
@@ -6583,7 +6537,7 @@
               (when (fixnum-type-p type1)
                 (emit 'swap))
               (emit-invokevirtual +lisp-object+ "add"
-                                  '("I") +lisp-object+)
+                                  '(:int) +lisp-object+)
               (fix-boxing representation result-type)
               (emit-move-from-stack target representation))
              (t
@@ -6655,7 +6609,7 @@
                     arg2 'stack :int)
               (emit-invokevirtual +lisp-object+
                                   "subtract"
-                                  '("I") +lisp-object+)
+                                  '(:int) +lisp-object+)
               (fix-boxing representation result-type)
               (emit-move-from-stack target representation))
              (t
@@ -6681,7 +6635,7 @@
            (compile-form arg2 'stack :int)
            (maybe-emit-clear-values arg1 arg2)
            (emit-invokevirtual +lisp-abstract-string+ "charAt"
-                               '("I") "C")
+                               '(:int) :char)
            (emit-move-from-stack target representation))
           ((and (eq representation :char)
                 (or (eq op 'CHAR) (< *safety* 3))
@@ -6692,14 +6646,14 @@
            (compile-form arg2 'stack :int)
            (maybe-emit-clear-values arg1 arg2)
            (emit-invokevirtual +lisp-abstract-string+ "charAt"
-                               '("I") "C")
+                               '(: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)
            (emit-invokevirtual +lisp-object+
                                (symbol-name op) ;; "CHAR" or "SCHAR"
-                               '("I") +lisp-object+)
+                               '(:int) +lisp-object+)
            (when (eq representation :char)
              (emit-unbox-character))
            (emit-move-from-stack target representation))
@@ -6736,7 +6690,7 @@
                (emit 'dup)
                (emit-move-from-stack value-register :char))
              (maybe-emit-clear-values arg1 arg2 arg3)
-             (emit-invokevirtual class "setCharAt" '("I" "C") nil)
+             (emit-invokevirtual class "setCharAt" '(:int :char) nil)
              (when target
                (emit 'iload value-register)
                (convert-representation :char representation)
@@ -6752,7 +6706,7 @@
                (arg2 (%caddr form)))
 	   (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 						      arg2 'stack :int)
-           (emit-invokevirtual +lisp-object+ "SVREF" '("I") +lisp-object+)
+           (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+)
            (fix-boxing representation nil)
            (emit-move-from-stack target representation)))
         (t
@@ -6772,7 +6726,7 @@
              (emit 'dup)
              (emit-move-from-stack value-register nil))
            (maybe-emit-clear-values arg1 arg2 arg3)
-           (emit-invokevirtual +lisp-object+ "svset" (list "I" +lisp-object+) nil)
+           (emit-invokevirtual +lisp-object+ "svset" (list :int +lisp-object+) nil)
            (when value-register
              (aload value-register)
              (emit-move-from-stack target nil))))
@@ -6807,7 +6761,7 @@
               (neq representation :char)) ; FIXME
          (compile-form (second form) 'stack nil)
          (compile-form (third form) 'stack :int)
-         (emit-invokevirtual +lisp-object+ "elt" '("I") +lisp-object+)
+         (emit-invokevirtual +lisp-object+ "elt" '(:int) +lisp-object+)
          (fix-boxing representation nil) ; FIXME use derived result type
          (emit-move-from-stack target representation))
         (t
@@ -6824,11 +6778,11 @@
          (:int
 	  (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 						     arg2 'stack :int)
-          (emit-invokevirtual +lisp-object+ "aref" '("I") "I"))
+          (emit-invokevirtual +lisp-object+ "aref" '(:int) :int))
          (:long
 	  (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 						     arg2 'stack :int)
-          (emit-invokevirtual +lisp-object+ "aref_long" '("I") "J"))
+          (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long))
          (:char
           (cond ((compiler-subtypep type1 'string)
                  (compile-form arg1 'stack nil) ; array
@@ -6836,18 +6790,18 @@
                  (compile-form arg2 'stack :int) ; index
                  (maybe-emit-clear-values arg1 arg2)
                  (emit-invokevirtual +lisp-abstract-string+
-                                     "charAt" '("I") "C"))
+                                     "charAt" '(:int) :char))
                 (t
 		 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
 							    arg2 'stack :int)
-                 (emit-invokevirtual +lisp-object+ "AREF" '("I") +lisp-object+)
+                 (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)
-          (emit-invokevirtual +lisp-object+ "AREF" '("I") +lisp-object+)
+          (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
           (convert-representation nil representation)))
        (emit-move-from-stack target representation)))
     (t
@@ -6880,9 +6834,9 @@
                     (emit-move-from-stack value-register nil))))
            (maybe-emit-clear-values arg1 arg2 arg3)
            (cond ((fixnum-type-p type3)
-                  (emit-invokevirtual +lisp-object+ "aset" '("I" "I") nil))
+                  (emit-invokevirtual +lisp-object+ "aset" '(:int :int) nil))
                  (t
-                  (emit-invokevirtual +lisp-object+ "aset" (list "I" +lisp-object+) nil)))
+                  (emit-invokevirtual +lisp-object+ "aset" (list :int +lisp-object+) nil)))
            (when value-register
              (cond ((fixnum-type-p type3)
                     (emit 'iload value-register)
@@ -6919,7 +6873,7 @@
              (t
               (emit-push-constant-int arg2)
               (emit-invokevirtual +lisp-object+ "getSlotValue"
-                                  '("I") +lisp-object+)))
+                                  '(:int) +lisp-object+)))
            (emit-move-from-stack target representation))
           ((fixnump arg2)
 	   (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
@@ -6927,15 +6881,15 @@
            (ecase representation
              (:int
               (emit-invokevirtual +lisp-object+ "getFixnumSlotValue"
-                                  '("I") "I"))
+                                  '(:int) :int))
              ((nil :char :long :float :double)
               (emit-invokevirtual +lisp-object+ "getSlotValue"
-                                  '("I") +lisp-object+)
+                                  '(:int) +lisp-object+)
               ;; (convert-representation NIL NIL) is a no-op
               (convert-representation nil representation))
              (:boolean
               (emit-invokevirtual +lisp-object+ "getSlotValueAsBoolean"
-                                  '("I") "Z")))
+                                  '(:int) :boolean)))
            (emit-move-from-stack target representation))
           (t
            (compile-function-call form target representation)))))
@@ -6974,7 +6928,7 @@
               (emit 'dup)
               (astore value-register))
             (emit-invokevirtual +lisp-object+ "setSlotValue"
-                                (list "I" +lisp-object+) nil)
+                                (list :int +lisp-object+) nil)
             (when value-register
               (aload value-register)
               (fix-boxing representation nil)
@@ -7039,7 +6993,7 @@
 	   (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
 						      arg2 'stack nil)
            (emit 'swap)
-           (emit-invokevirtual +lisp-object+ "nthcdr" '("I") +lisp-object+)
+           (emit-invokevirtual +lisp-object+ "nthcdr" '(:int) +lisp-object+)
            (fix-boxing representation nil)
            (emit-move-from-stack target representation))
           (t
@@ -7354,7 +7308,7 @@
   (cond ((check-arg-count form 1)
          (let ((arg (%cadr form)))
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
-           (emit-invokevirtual +lisp-object+ "sxhash" nil "I")
+           (emit-invokevirtual +lisp-object+ "sxhash" nil :int)
            (convert-representation :int representation)
            (emit-move-from-stack target representation)))
         (t
@@ -7835,27 +7789,27 @@
         (setf *using-arg-array* t)
         (setf *hairy-arglist-p* t)
         (return-from analyze-args
-          (get-descriptor (list +lisp-object-array+) +lisp-object+)))
+          (descriptor +lisp-object+ +lisp-object-array+)))
       (return-from analyze-args
         (cond ((<= arg-count call-registers-limit)
-               (get-descriptor (lisp-object-arg-types arg-count) +lisp-object+))
+               (apply #'descriptor +lisp-object+
+                      (lisp-object-arg-types arg-count)))
               (t (setf *using-arg-array* t)
                  (setf (compiland-arity compiland) arg-count)
-                 (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
+                 (descriptor +lisp-object+ +lisp-object-array+)))))
     (when (or (memq '&KEY args)
               (memq '&OPTIONAL args)
               (memq '&REST args))
       (setf *using-arg-array* t)
       (setf *hairy-arglist-p* t)
-      (return-from analyze-args
-                   (get-descriptor (list +lisp-object-array+) +lisp-object+)))
+      (return-from analyze-args (descriptor +lisp-object+ +lisp-object-array+)))
     (cond ((<= arg-count call-registers-limit)
-           (get-descriptor (lisp-object-arg-types (length args))
-                            +lisp-object+))
+           (apply #'descriptor +lisp-object+
+                      (lisp-object-arg-types (length args))))
           (t
            (setf *using-arg-array* t)
            (setf (compiland-arity compiland) arg-count)
-           (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
+           (descriptor +lisp-object+ +lisp-object-array+)))))
 
 (defmacro with-open-class-file ((var class-file) &body body)
   `(with-open-file (,var (abcl-class-file-pathname ,class-file)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Mon Aug  2 16:59:52 2010
@@ -213,8 +213,38 @@
 (defun descriptor (return-type &rest argument-types)
   "Returns a string describing the `return-type' and `argument-types'
 in JVM-internal representation."
-  (format nil "(~{~A~})~A" (mapcar #'internal-field-ref argument-types)
-          (internal-field-ref return-type)))
+  (let* ((arg-strings (mapcar #'internal-field-ref argument-types))
+         (ret-string (internal-field-ref return-type))
+         (size (+ 2 (reduce #'+ arg-strings
+                            :key #'length
+                            :initial-value (length ret-string))))
+         (str (make-array size :fill-pointer 0 :element-type 'character)))
+    (with-output-to-string (s str)
+      (princ #\( s)
+      (dolist (arg-string arg-strings)
+        (princ arg-string s))
+      (princ #\) s)
+      (princ ret-string s))
+    str)
+;;  (format nil "(~{~A~})~A" 
+;;          (internal-field-ref return-type))
+  )
+
+(defun descriptor-stack-effect (return-type &rest argument-types)
+  "Returns the effect on the stack position of the `argument-types' and
+`return-type' of a method call.
+
+If the method consumes an implicit `this' argument, this function does not
+take that effect into account."
+  (flet ((type-stack-effect (arg)
+           (case arg
+             ((:long :double) 2)
+             ((nil :void) 0)
+             (otherwise 1))))
+    (+ (reduce #'- argument-types
+               :key #'type-stack-effect
+               :initial-value 0)
+       (type-stack-effect return-type))))
 
 
 (defstruct pool



From ehuelsmann at common-lisp.net  Mon Aug  2 21:23:50 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 02 Aug 2010 17:23:50 -0400
Subject: [armedbear-cvs] r12857 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Og2UA-0003Hx-I3@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  2 17:23:49 2010
New Revision: 12857

Log:
Remove unused function GET-DESCRIPTOR.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  2 17:23:49 2010
@@ -412,10 +412,6 @@
            (emit 'dup2_x2)
            (emit 'pop2)))))
 
-(declaim (inline get-descriptor))
-(defun get-descriptor (arg-types return-type)
-  (apply #'descriptor return-type arg-types))
-
 (declaim (ftype (function * t) emit-invokestatic))
 (defun emit-invokestatic (class-name method-name arg-types return-type)
   (let* ((descriptor (apply #'descriptor return-type arg-types))



From ehuelsmann at common-lisp.net  Mon Aug  2 21:44:03 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 02 Aug 2010 17:44:03 -0400
Subject: [armedbear-cvs] r12858 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Og2nj-0004pN-A8@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  2 17:44:02 2010
New Revision: 12858

Log:
Finalize CLASS-NAME integration: decommission !CLASS-REF.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  2 17:44:02 2010
@@ -108,7 +108,8 @@
   (declare (optimize speed))
   (pool-get (list 9
                   (pool-class class-name)
-                  (pool-name-and-type field-name type-name))))
+                  (pool-name-and-type field-name
+                                      (internal-field-ref type-name)))))
 
 ;; (tag class-index name-and-type-index)
 (declaim (ftype (function (string string string) fixnum) pool-method))
@@ -211,13 +212,6 @@
       (code-add-exception-handler *current-code-attribute*
                                   start end handler type)))
 
-(defun !class-ref (class-name)
-  "To be eliminated when all hard-coded strings are
-replaced by `class-name' structures"
-  (if (or (symbolp class-name) (typep class-name 'class-name))
-      (internal-field-ref class-name)
-      class-name))
-
 (defstruct (instruction (:constructor %make-instruction (opcode args)))
   (opcode 0 :type (integer 0 255))
   args
@@ -504,14 +498,14 @@
 (defknown emit-getstatic (t t t) t)
 (defun emit-getstatic (class-name field-name type)
   (let ((index (if (null *current-code-attribute*)
-                   (pool-field class-name field-name (!class-ref type))
+                   (pool-field class-name field-name type)
                    (pool-add-field-ref *pool* class-name field-name type))))
     (apply #'%emit 'getstatic (u2 index))))
 
 (defknown emit-putstatic (t t t) t)
 (defun emit-putstatic (class-name field-name type)
   (let ((index (if (null *current-code-attribute*)
-                   (pool-field class-name field-name (!class-ref type))
+                   (pool-field class-name field-name type)
                    (pool-add-field-ref *pool* class-name field-name type))))
     (apply #'%emit 'putstatic (u2 index))))
 
@@ -1169,7 +1163,7 @@
 (define-resolver (180 181) (instruction)
   (let* ((args (instruction-args instruction))
          (index (pool-field (first args)
-                            (second args) (!class-ref (third args)))))
+                            (second args) (third args))))
     (inst (instruction-opcode instruction) (u2 index))))
 
 ;; new, anewarray, checkcast, instanceof class-name
@@ -1915,7 +1909,7 @@
 
 (defknown declare-field (t t t) t)
 (defun declare-field (name descriptor access-flags)
-  (let ((field (make-field name (!class-ref descriptor))))
+  (let ((field (make-field name (internal-field-ref descriptor))))
     ;; final static <access-flags>
     (setf (field-access-flags field)
           (logior +field-flag-final+ +field-flag-static+ access-flags))



From ehuelsmann at common-lisp.net  Wed Aug  4 20:25:04 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Wed, 04 Aug 2010 16:25:04 -0400
Subject: [armedbear-cvs] r12859 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OgkWO-0002XP-LX@common-lisp.net>

Author: ehuelsmann
Date: Wed Aug  4 16:25:03 2010
New Revision: 12859

Log:
Introduce EMIT-GETFIELD and EMIT-PUTFIELD to further improve the
resolver vs emitter layers.


Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Wed Aug  4 16:25:03 2010
@@ -509,6 +509,23 @@
                    (pool-add-field-ref *pool* class-name field-name type))))
     (apply #'%emit 'putstatic (u2 index))))
 
+(declaim (inline emit-getfield emit-putfield))
+(defknown emit-getfield (t t t) t)
+(defun emit-getfield (class-name field-name type)
+  (let* ((index (if (null *current-code-attribute*)
+                    (pool-field class-name field-name type)
+                    (pool-add-field-ref *pool* class-name field-name type))))
+    (apply #'%emit 'getfield (u2 index))))
+
+(defknown emit-putfield (t t t) t)
+(defun emit-putfield (class-name field-name type)
+  (let* ((index (if (null *current-code-attribute*)
+                    (pool-field class-name field-name type)
+                    (pool-add-field-ref *pool* class-name field-name type))))
+    (apply #'%emit 'putfield (u2 index))))
+
+
+
 (defvar type-representations '((:int fixnum)
                                (:long (integer #.most-negative-java-long
                                                #.most-positive-java-long))
@@ -552,7 +569,7 @@
                             (lisp-object-arg-types 1) :char))
         (t
          (emit 'checkcast +lisp-character+)
-         (emit 'getfield +lisp-character+ "value" :char))))
+         (emit-getfield +lisp-character+ "value" :char))))
 
 ;;                     source type /
 ;;                         targets   :boolean :char    :int :long :float :double
@@ -841,7 +858,7 @@
                             (lisp-object-arg-types 1) :int))
         (t
          (emit 'checkcast +lisp-fixnum+)
-         (emit 'getfield +lisp-fixnum+ "value" :int))))
+         (emit-getfield +lisp-fixnum+ "value" :int))))
 
 (defknown emit-unbox-long () t)
 (defun emit-unbox-long ()
@@ -856,7 +873,7 @@
                             (lisp-object-arg-types 1) :float))
         (t
          (emit 'checkcast +lisp-single-float+)
-         (emit 'getfield +lisp-single-float+ "value" :float))))
+         (emit-getfield +lisp-single-float+ "value" :float))))
 
 (defknown emit-unbox-double () t)
 (defun emit-unbox-double ()
@@ -866,7 +883,7 @@
                             (lisp-object-arg-types 1) :double))
         (t
          (emit 'checkcast +lisp-double-float+)
-         (emit 'getfield +lisp-double-float+ "value" :double))))
+         (emit-getfield +lisp-double-float+ "value" :double))))
 
 (defknown fix-boxing (t t) t)
 (defun fix-boxing (required-representation derived-type)
@@ -877,7 +894,7 @@
          (cond ((and (fixnum-type-p derived-type)
                      (< *safety* 3))
                 (emit 'checkcast +lisp-fixnum+)
-                (emit 'getfield +lisp-fixnum+ "value" :int))
+                (emit-getfield +lisp-fixnum+ "value" :int))
                (t
                 (emit-invokevirtual +lisp-object+ "intValue" nil :int))))
         ((eq required-representation :char)
@@ -1161,10 +1178,8 @@
 
 ;; getfield, putfield class-name field-name type-name
 (define-resolver (180 181) (instruction)
-  (let* ((args (instruction-args instruction))
-         (index (pool-field (first args)
-                            (second args) (third args))))
-    (inst (instruction-opcode instruction) (u2 index))))
+  ;; we used to create the pool-field here; that moved to the emit-* layer
+  instruction)
 
 ;; new, anewarray, checkcast, instanceof class-name
 (define-resolver (187 189 192 193) (instruction)
@@ -1190,8 +1205,9 @@
         instruction)))
 
 (defun resolve-instructions (code)
-  (let ((vector (make-array 512 :fill-pointer 0 :adjustable t)))
-    (dotimes (index (length code) vector)
+  (let* ((len (length code))
+         (vector (make-array (ash len 1) :fill-pointer 0 :adjustable t)))
+    (dotimes (index len vector)
       (declare (type (unsigned-byte 16) index))
       (let ((instruction (svref code index)))
         (case (instruction-opcode instruction)
@@ -1200,8 +1216,8 @@
                   (list
                    (inst 'aload *thread*)
                    (inst 'aconst_null)
-                   (inst 'putfield (list +lisp-thread+ "_values"
-                                         +lisp-object-array+)))))
+                   (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
+                                                   +lisp-object-array+))))))
              (dolist (instruction instructions)
                (vector-push-extend (resolve-instruction instruction) vector))))
           (t
@@ -3739,14 +3755,14 @@
     (compile-form first-subform result-register nil)
     ;; Save multiple values returned by first subform.
     (emit-push-current-thread)
-    (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+)
+    (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
     (astore values-register)
     (dolist (subform subforms)
       (compile-form subform nil nil))
     ;; Restore multiple values returned by first subform.
     (emit-push-current-thread)
     (aload values-register)
-    (emit 'putfield +lisp-thread+ "_values" +lisp-object-array+)
+    (emit-putfield +lisp-thread+ "_values" +lisp-object-array+)
     ;; Result.
     (aload result-register)
     (fix-boxing representation nil)
@@ -3945,7 +3961,7 @@
              (compile-form (third form) result-register nil)
              ;; Store values from values form in values register.
              (emit-push-current-thread)
-             (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+)
+             (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
              (emit-move-from-stack values-register)
              ;; Did we get just one value?
              (aload values-register)
@@ -4120,7 +4136,7 @@
            (emit-push-constant-int (variable-closure-index variable))
            (emit 'aaload)
            (emit-swap representation nil)
-           (emit 'putfield +lisp-closure-binding+ "value" +lisp-object+))
+           (emit-putfield +lisp-closure-binding+ "value" +lisp-object+))
           ((variable-environment variable)
            (assert (not *file-compilation*))
            (emit-load-externalized-object (variable-environment variable)
@@ -4152,7 +4168,7 @@
          (aload (compiland-closure-register *current-compiland*))
          (emit-push-constant-int (variable-closure-index variable))
          (emit 'aaload)
-         (emit 'getfield +lisp-closure-binding+ "value" +lisp-object+))
+         (emit-getfield +lisp-closure-binding+ "value" +lisp-object+))
         ((variable-environment variable)
          (assert (not *file-compilation*))
          (emit-load-externalized-object (variable-environment variable)
@@ -4411,11 +4427,11 @@
         (emit 'dup)
         (astore go-register)
         ;; Get the tag.
-        (emit 'getfield +lisp-go+ "tagbody" +lisp-object+) ; Stack depth is still 1.
+        (emit-getfield +lisp-go+ "tagbody" +lisp-object+) ; Stack depth is still 1.
         (emit-push-variable (tagbody-id-variable block))
         (emit 'if_acmpne RETHROW) ;; Not this TAGBODY
         (aload go-register)
-        (emit 'getfield +lisp-go+ "tag" +lisp-object+) ; Stack depth is still 1.
+        (emit-getfield +lisp-go+ "tag" +lisp-object+) ; Stack depth is still 1.
         (astore tag-register)
         ;; Don't actually generate comparisons for tags
         ;; to which there is no non-local GO instruction
@@ -4586,7 +4602,7 @@
         (label HANDLER)
         ;; The Return object is on the runtime stack. Stack depth is 1.
         (emit 'dup) ; Stack depth is 2.
-        (emit 'getfield +lisp-return+ "tag" +lisp-object+) ; Still 2.
+        (emit-getfield +lisp-return+ "tag" +lisp-object+) ; Still 2.
         (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.
@@ -4596,7 +4612,7 @@
         (emit-move-to-variable (block-id-variable block))
         (emit 'athrow)
         (label THIS-BLOCK)
-        (emit 'getfield +lisp-return+ "result" +lisp-object+)
+        (emit-getfield +lisp-return+ "result" +lisp-object+)
         (emit-move-from-stack target) ; Stack depth is 0.
         ;; Finally...
         (add-exception-handler BEGIN-BLOCK END-BLOCK HANDLER +lisp-return+)
@@ -7123,7 +7139,7 @@
                 (not (enclosed-by-runtime-bindings-creating-block-p
                       (variable-block variable))))
            (aload (variable-binding-register variable))
-           (emit 'getfield +lisp-special-binding+ "value"
+           (emit-getfield +lisp-special-binding+ "value"
                  +lisp-object+))
           (t
            (emit-push-current-thread)
@@ -7203,7 +7219,7 @@
              (aload (variable-binding-register variable))
              (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
              (emit 'dup_x1) ;; copy past th
-             (emit 'putfield +lisp-special-binding+ "value"
+             (emit-putfield +lisp-special-binding+ "value"
                    +lisp-object+))
             ((and (consp value-form)
                   (eq (first value-form) 'CONS)
@@ -7311,7 +7327,7 @@
     (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3))
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
            (emit 'checkcast +lisp-symbol+)
-           (emit 'getfield  +lisp-symbol+ "name" +lisp-simple-string+)
+           (emit-getfield  +lisp-symbol+ "name" +lisp-simple-string+)
            (emit-move-from-stack target representation))
           (t
            (compile-function-call form target representation)))))
@@ -7570,7 +7586,7 @@
       (label THROW-HANDLER) ; Start of handler for THROW.
       ;; The Throw object is on the runtime stack. Stack depth is 1.
       (emit 'dup) ; Stack depth is 2.
-      (emit 'getfield +lisp-throw+ "tag" +lisp-object+) ; Still 2.
+      (emit-getfield +lisp-throw+ "tag" +lisp-object+) ; Still 2.
       (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.
@@ -7647,7 +7663,7 @@
         (compile-form protected-form result-register nil)
         (unless (single-valued-p protected-form)
           (emit-push-current-thread)
-          (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+)
+          (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
           (astore values-register))
         (label END-PROTECTED-RANGE))
       (let ((*register* *register*))
@@ -7660,7 +7676,7 @@
       ;; The Throwable object is on the runtime stack. Stack depth is 1.
       (astore exception-register)
       (emit-push-current-thread)
-      (emit 'getfield +lisp-thread+ "_values" +lisp-object-array+)
+      (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
       (astore values-register)
       (let ((*register* *register*))
         (dolist (subform cleanup-forms)
@@ -7668,7 +7684,7 @@
       (maybe-emit-clear-values cleanup-forms)
       (emit-push-current-thread)
       (aload values-register)
-      (emit 'putfield +lisp-thread+ "_values" +lisp-object-array+)
+      (emit-putfield +lisp-thread+ "_values" +lisp-object-array+)
       (aload exception-register)
       (emit 'athrow) ; Re-throw exception.
       (label EXIT)
@@ -7676,7 +7692,7 @@
       (unless (single-valued-p protected-form)
         (emit-push-current-thread)
         (aload values-register)
-        (emit 'putfield +lisp-thread+ "_values" +lisp-object-array+))
+        (emit-putfield +lisp-thread+ "_values" +lisp-object-array+))
       ;; Result.
       (aload result-register)
       (emit-move-from-stack target)
@@ -7967,7 +7983,7 @@
             (emit 'anewarray +lisp-closure-binding+))
         (progn
           (aload 0)
-          (emit 'getfield +lisp-compiled-closure+ "ctx"
+          (emit-getfield +lisp-compiled-closure+ "ctx"
                 +closure-binding-array+)
           (when local-closure-vars
             ;; in all other cases, it gets stored in the register below



From ehuelsmann at common-lisp.net  Wed Aug  4 21:36:42 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Wed, 04 Aug 2010 17:36:42 -0400
Subject: [armedbear-cvs] r12860 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ogldi-0007i1-S2@common-lisp.net>

Author: ehuelsmann
Date: Wed Aug  4 17:36:42 2010
New Revision: 12860

Log:
Introduce EMIT-NEW, EMIT-ANEWARRAY, EMIT-CHECKCAST and EMIT-INSTANCEOF
to further improve the resolvers vs emitters layering.


Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-file.lisp	Wed Aug  4 17:36:42 2010
@@ -691,10 +691,10 @@
 				(jvm::emit 'jvm::aload 1)
 				(jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance"
 							 nil jvm::+java-object+)
-				(jvm::emit 'jvm::checkcast +fasl-classloader+)
+				(jvm::emit-checkcast +fasl-classloader+)
 				(jvm::emit 'jvm::dup)
 				(jvm::emit-push-constant-int ,(1- i))
-				(jvm::emit 'jvm::new ,class-name)
+				(jvm::emit-new ,class-name)
 				(jvm::emit 'jvm::dup)
 				(jvm::emit-invokespecial-init ,class-name '())
 				(jvm::emit-invokevirtual +fasl-classloader+

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Wed Aug  4 17:36:42 2010
@@ -525,6 +525,23 @@
     (apply #'%emit 'putfield (u2 index))))
 
 
+(defknown emit-new (t) t)
+(declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof))
+(defun emit-new (class-name)
+  (apply #'%emit 'new (u2 (pool-class class-name))))
+
+(defknown emit-anewarray (t) t)
+(defun emit-anewarray (class-name)
+  (apply #'%emit 'anewarray (u2 (pool-class class-name))))
+
+(defknown emit-checkcast (t) t)
+(defun emit-checkcast (class-name)
+  (apply #'%emit 'checkcast (u2 (pool-class class-name))))
+
+(defknown emit-instanceof (t) t)
+(defun emit-instanceof (class-name)
+  (apply #'%emit 'instanceof (u2 (pool-class class-name))))
+
 
 (defvar type-representations '((:int fixnum)
                                (:long (integer #.most-negative-java-long
@@ -558,7 +575,7 @@
 
 (defknown emit-unbox-boolean () t)
 (defun emit-unbox-boolean ()
-  (emit 'instanceof +lisp-nil+)
+  (emit-instanceof +lisp-nil+)
   (emit 'iconst_1)
   (emit 'ixor))  ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit
 
@@ -568,7 +585,7 @@
          (emit-invokestatic +lisp-character+ "getValue"
                             (lisp-object-arg-types 1) :char))
         (t
-         (emit 'checkcast +lisp-character+)
+         (emit-checkcast +lisp-character+)
          (emit-getfield +lisp-character+ "value" :char))))
 
 ;;                     source type /
@@ -713,7 +730,7 @@
                                            (symbol-name expected-type))))
         (LABEL1 (gensym)))
     (emit-load-local-variable variable)
-    (emit 'instanceof instanceof-class)
+    (emit-instanceof instanceof-class)
     (emit 'ifne LABEL1)
     (emit-load-local-variable variable)
     (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name
@@ -857,7 +874,7 @@
          (emit-invokestatic +lisp-fixnum+ "getValue"
                             (lisp-object-arg-types 1) :int))
         (t
-         (emit 'checkcast +lisp-fixnum+)
+         (emit-checkcast +lisp-fixnum+)
          (emit-getfield +lisp-fixnum+ "value" :int))))
 
 (defknown emit-unbox-long () t)
@@ -872,7 +889,7 @@
          (emit-invokestatic +lisp-single-float+ "getValue"
                             (lisp-object-arg-types 1) :float))
         (t
-         (emit 'checkcast +lisp-single-float+)
+         (emit-checkcast +lisp-single-float+)
          (emit-getfield +lisp-single-float+ "value" :float))))
 
 (defknown emit-unbox-double () t)
@@ -882,7 +899,7 @@
          (emit-invokestatic +lisp-double-float+ "getValue"
                             (lisp-object-arg-types 1) :double))
         (t
-         (emit 'checkcast +lisp-double-float+)
+         (emit-checkcast +lisp-double-float+)
          (emit-getfield +lisp-double-float+ "value" :double))))
 
 (defknown fix-boxing (t t) t)
@@ -893,7 +910,7 @@
         ((eq required-representation :int)
          (cond ((and (fixnum-type-p derived-type)
                      (< *safety* 3))
-                (emit 'checkcast +lisp-fixnum+)
+                (emit-checkcast +lisp-fixnum+)
                 (emit-getfield +lisp-fixnum+ "value" :int))
                (t
                 (emit-invokevirtual +lisp-object+ "intValue" nil :int))))
@@ -1183,9 +1200,8 @@
 
 ;; new, anewarray, checkcast, instanceof class-name
 (define-resolver (187 189 192 193) (instruction)
-  (let* ((args (instruction-args instruction))
-         (index (pool-class (first args))))
-    (inst (instruction-opcode instruction) (u2 index))))
+  ;; we used to create the pool-class here; that moved to the emit-* layer
+  instruction)
 
 ;; iinc
 (define-resolver 132 (instruction)
@@ -1754,7 +1770,7 @@
                (let ((count-sym (gensym)))
                  `(progn
                     (emit-push-constant-int (length ,params))
-                    (emit 'anewarray +lisp-closure-parameter+)
+                    (emit-anewarray +lisp-closure-parameter+)
                     (astore (setf ,register (method-max-locals constructor)))
                     (incf (method-max-locals constructor))
                     (do* ((,count-sym 0 (1+ ,count-sym))
@@ -1764,7 +1780,7 @@
                       (declare (ignorable ,param))
                       (aload ,register)
                       (emit-push-constant-int ,count-sym)
-                      (emit 'new +lisp-closure-parameter+)
+                      (emit-new +lisp-closure-parameter+)
                       (emit 'dup)
                       , at body
                       (emit 'aastore))))))
@@ -2005,21 +2021,21 @@
 
 (defun serialize-float (s)
   "Generates code to restore a serialized single-float."
-  (emit 'new +lisp-single-float+)
+  (emit-new +lisp-single-float+)
   (emit 'dup)
   (emit 'ldc (pool-float s))
   (emit-invokespecial-init +lisp-single-float+ '(:float)))
 
 (defun serialize-double (d)
   "Generates code to restore a serialized double-float."
-  (emit 'new +lisp-double-float+)
+  (emit-new +lisp-double-float+)
   (emit 'dup)
   (emit 'ldc2_w (pool-double d))
   (emit-invokespecial-init +lisp-double-float+ '(:double)))
 
 (defun serialize-string (string)
   "Generate code to restore a serialized string."
-  (emit 'new +lisp-simple-string+)
+  (emit-new +lisp-simple-string+)
   (emit 'dup)
   (emit 'ldc (pool-string string))
   (emit-invokespecial-init +lisp-simple-string+ (list +java-string+)))
@@ -2052,7 +2068,7 @@
        (emit-push-constant-int (dump-uninterned-symbol-index symbol))
        (emit-invokestatic +lisp-load+ "getUninternedSymbol" '(:int)
                           +lisp-object+)
-       (emit 'checkcast +lisp-symbol+))
+       (emit-checkcast +lisp-symbol+))
       ((keywordp symbol)
        (emit 'ldc (pool-string (symbol-name symbol)))
        (emit-invokestatic +lisp+ "internKeyword"
@@ -2111,7 +2127,7 @@
       (when existing
         (emit-getstatic *this-class* (cdr existing) field-type)
         (when cast
-          (emit 'checkcast cast))
+          (emit-checkcast cast))
         (return-from emit-load-externalized-object field-type)))
 
     ;; We need to set up the serialized value
@@ -2127,7 +2143,7 @@
            (emit-invokestatic +lisp+ "recall"
                               (list +java-string+) +lisp-object+)
            (when (not (eq field-type +lisp-object+))
-             (emit 'checkcast field-type))
+             (emit-checkcast field-type))
            (emit-putstatic *this-class* field-name field-type)
            (setf *static-code* *code*)))
         (*declare-inline*
@@ -2141,7 +2157,7 @@
 
       (emit-getstatic *this-class* field-name field-type)
       (when cast
-        (emit 'checkcast cast))
+        (emit-checkcast cast))
       field-type)))
 
 (defknown declare-function (symbol &optional setf) string)
@@ -2172,7 +2188,7 @@
          (if (eq class *this-class*)
              (progn ;; generated by the DECLARE-OBJECT*'s above
                (emit-getstatic class name +lisp-object+)
-               (emit 'checkcast +lisp-symbol+))
+               (emit-checkcast +lisp-symbol+))
              (emit-getstatic class name +lisp-symbol+))
          (emit-invokevirtual +lisp-symbol+
                              (if setf
@@ -2207,7 +2223,7 @@
           (*code* *static-code*))
      ;; fixme *declare-inline*
      (declare-field g +lisp-object+ +field-access-private+)
-     (emit 'new class-name)
+     (emit-new class-name)
      (emit 'dup)
      (emit-invokespecial-init class-name '())
      (emit-putstatic *this-class* g +lisp-object+)
@@ -2716,7 +2732,7 @@
          (let ((key-form (%cadr form))
                (ht-form (%caddr form)))
            (compile-form ht-form 'stack nil)
-           (emit 'checkcast +lisp-hash-table+)
+           (emit-checkcast +lisp-hash-table+)
            (compile-form key-form 'stack nil)
            (maybe-emit-clear-values ht-form key-form)
            (emit-invokevirtual +lisp-hash-table+ "gethash1"
@@ -2734,7 +2750,7 @@
                (ht-form (%caddr form))
                (value-form (fourth form)))
            (compile-form ht-form 'stack nil)
-           (emit 'checkcast +lisp-hash-table+)
+           (emit-checkcast +lisp-hash-table+)
            (compile-form key-form 'stack nil)
            (compile-form value-form 'stack nil)
            (maybe-emit-clear-values ht-form key-form value-form)
@@ -2781,7 +2797,7 @@
                      (setf must-clear-values t)))))
               (t
                (emit-push-constant-int numargs)
-               (emit 'anewarray +lisp-object+)
+               (emit-anewarray +lisp-object+)
                (let ((i 0))
                  (dolist (arg args)
                    (emit 'dup)
@@ -2956,7 +2972,7 @@
     (aload (compiland-closure-register compiland))        ;; src
     (emit-push-constant-int 0)                            ;; srcPos
     (emit-push-constant-int (length *closure-variables*))
-    (emit 'anewarray +lisp-closure-binding+)             ;; dest
+    (emit-anewarray +lisp-closure-binding+)             ;; dest
     (emit 'dup)
     (astore register)  ;; save dest value
     (emit-push-constant-int 0)                            ;; destPos
@@ -3005,7 +3021,7 @@
              (emit-getstatic *this-class* g +lisp-object+)
                                         ; Stack: template-function
              (when *closure-variables*
-               (emit 'checkcast +lisp-compiled-closure+)
+               (emit-checkcast +lisp-compiled-closure+)
                (duplicate-closure-array compiland)
                (emit-invokestatic +lisp+ "makeCompiledClosure"
                                   (list +lisp-object+ +closure-binding-array+)
@@ -3220,7 +3236,7 @@
   (when (check-arg-count form 1)
     (let ((arg (%cadr form)))
       (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
-      (emit 'instanceof java-class)
+      (emit-instanceof java-class)
       'ifeq)))
 
 (defun p2-test-bit-vector-p (form)
@@ -3835,7 +3851,7 @@
 (declaim (ftype (function (t) t) emit-new-closure-binding))
 (defun emit-new-closure-binding (variable)
   ""
-  (emit 'new +lisp-closure-binding+)            ;; value c-b
+  (emit-new +lisp-closure-binding+)            ;; value c-b
   (emit 'dup_x1)                                 ;; c-b value c-b
   (emit 'swap)                                   ;; c-b c-b value
   (emit-invokespecial-init +lisp-closure-binding+
@@ -4393,7 +4409,7 @@
     (when (tagbody-id-variable block)
       ;; we have a block variable; that should be a closure variable
       (assert (not (null (variable-closure-index (tagbody-id-variable block)))))
-      (emit 'new +lisp-object+)
+      (emit-new +lisp-object+)
       (emit 'dup)
       (emit-invokespecial-init +lisp-object+ '())
       (emit-new-closure-binding (tagbody-id-variable block)))
@@ -4500,7 +4516,7 @@
   ((aver (or (null representation) (eq representation :boolean)))
    (check-arg-count form 1))
   (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil)
-  (emit 'instanceof +lisp-cons+)
+  (emit-instanceof +lisp-cons+)
   (let ((LABEL1 (gensym))
         (LABEL2 (gensym)))
     (emit 'ifeq LABEL1)
@@ -4529,7 +4545,7 @@
 	   (compile-forms-and-maybe-emit-clear-values arg nil nil))
           (t
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
-           (emit 'instanceof java-class)
+           (emit-instanceof java-class)
            (convert-representation :boolean representation)
            (emit-move-from-stack target representation)))))
 
@@ -4583,7 +4599,7 @@
     (when (block-id-variable block)
       ;; we have a block variable; that should be a closure variable
       (assert (not (null (variable-closure-index (block-id-variable block)))))
-      (emit 'new +lisp-object+)
+      (emit-new +lisp-object+)
       (emit 'dup)
       (emit-invokespecial-init +lisp-object+ '())
       (emit-new-closure-binding (block-id-variable block)))
@@ -4679,7 +4695,7 @@
 
 (define-inlined-function p2-cons (form target representation)
   ((check-arg-count form 2))
-  (emit 'new +lisp-cons+)
+  (emit-new +lisp-cons+)
   (emit 'dup)
   (let* ((args (%cdr form))
          (arg1 (%car args))
@@ -4840,7 +4856,7 @@
     (when (compiland-closure-register parent)
       (dformat t "(compiland-closure-register parent) = ~S~%"
 	       (compiland-closure-register parent))
-      (emit 'checkcast +lisp-compiled-closure+)
+      (emit-checkcast +lisp-compiled-closure+)
       (duplicate-closure-array parent)
       (emit-invokestatic +lisp+ "makeCompiledClosure"
 			 (list +lisp-object+ +closure-binding-array+)
@@ -4970,7 +4986,7 @@
                                         ; Stack: template-function
 
                (when (compiland-closure-register *current-compiland*)
-                 (emit 'checkcast +lisp-compiled-closure+)
+                 (emit-checkcast +lisp-compiled-closure+)
                  (duplicate-closure-array *current-compiland*)
                  (emit-invokestatic +lisp+ "makeCompiledClosure"
                                     (list +lisp-object+ +closure-binding-array+)
@@ -5589,7 +5605,7 @@
               (fixnum-type-p (derive-compiler-type (second form)))
               (null representation))
          (let ((arg (second form)))
-           (emit 'new +lisp-simple-vector+)
+           (emit-new +lisp-simple-vector+)
            (emit 'dup)
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
            (emit-invokespecial-init +lisp-simple-vector+ '(:int))
@@ -5618,7 +5634,7 @@
                 ((VECTOR SIMPLE-VECTOR)
                  (setf class +lisp-simple-vector+)))))
         (when class
-          (emit 'new class)
+          (emit-new class)
           (emit 'dup)
 	  (compile-forms-and-maybe-emit-clear-values arg2 'stack :int)
           (emit-invokespecial-init class '(:int))
@@ -5633,7 +5649,7 @@
               (= (length form) 2)
               (null representation))
          (let ((arg (second form)))
-           (emit 'new +lisp-simple-string+)
+           (emit-new +lisp-simple-string+)
            (emit 'dup)
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
            (emit-invokespecial-init +lisp-simple-string+ '(:int))
@@ -5644,10 +5660,10 @@
 (defun p2-%make-structure (form target representation)
   (cond ((and (check-arg-count form 2)
               (eq (derive-type (%cadr form)) 'SYMBOL))
-         (emit 'new +lisp-structure-object+)
+         (emit-new +lisp-structure-object+)
          (emit 'dup)
          (compile-form (%cadr form) 'stack nil)
-         (emit 'checkcast +lisp-symbol+)
+         (emit-checkcast +lisp-symbol+)
          (compile-form (%caddr form) 'stack nil)
          (maybe-emit-clear-values (%cadr form) (%caddr form))
          (emit-invokevirtual +lisp-object+ "copyToArray"
@@ -5664,10 +5680,10 @@
          (slot-count (length slot-forms)))
     (cond ((and (<= 1 slot-count 6)
                 (eq (derive-type (%car args)) 'SYMBOL))
-           (emit 'new +lisp-structure-object+)
+           (emit-new +lisp-structure-object+)
            (emit 'dup)
            (compile-form (%car args) 'stack nil)
-           (emit 'checkcast +lisp-symbol+)
+           (emit-checkcast +lisp-symbol+)
            (dolist (slot-form slot-forms)
              (compile-form slot-form 'stack nil))
            (apply 'maybe-emit-clear-values args)
@@ -5680,7 +5696,7 @@
 
 (defun p2-make-hash-table (form target representation)
   (cond ((= (length form) 1) ; no args
-         (emit 'new +lisp-eql-hash-table+)
+         (emit-new +lisp-eql-hash-table+)
          (emit 'dup)
          (emit-invokespecial-init +lisp-eql-hash-table+ nil)
          (fix-boxing representation nil)
@@ -5694,7 +5710,7 @@
   (let ((arg (%cadr form)))
     (cond ((eq (derive-compiler-type arg) 'STREAM)
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
-           (emit 'checkcast +lisp-stream+)
+           (emit-checkcast +lisp-stream+)
            (emit-invokevirtual +lisp-stream+ "getElementType"
                                nil +lisp-object+)
            (emit-move-from-stack target representation))
@@ -5713,7 +5729,7 @@
                 (eq type2 'STREAM))
            (compile-form arg1 'stack :int)
            (compile-form arg2 'stack nil)
-           (emit 'checkcast +lisp-stream+)
+           (emit-checkcast +lisp-stream+)
            (maybe-emit-clear-values arg1 arg2)
            (emit 'swap)
            (emit-invokevirtual +lisp-stream+ "_writeByte" '(:int) nil)
@@ -5741,7 +5757,7 @@
               (type1 (derive-compiler-type arg1)))
          (cond ((compiler-subtypep type1 'stream)
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
-                (emit 'checkcast +lisp-stream+)
+                (emit-checkcast +lisp-stream+)
                 (emit-push-constant-int 1)
                 (emit-push-nil)
                 (emit-invokevirtual +lisp-stream+ "readLine"
@@ -5755,7 +5771,7 @@
               (arg2 (%cadr args)))
          (cond ((and (compiler-subtypep type1 'stream) (null arg2))
 		(compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
-                (emit 'checkcast +lisp-stream+)
+                (emit-checkcast +lisp-stream+)
                 (emit-push-constant-int 0)
                 (emit-push-nil)
                 (emit-invokevirtual +lisp-stream+ "readLine"
@@ -6304,7 +6320,7 @@
         (cond ((subtypep type2 'VECTOR)
                (compile-form arg1 'stack nil)
                (compile-form arg2 'stack nil)
-               (emit 'checkcast +lisp-abstract-vector+)
+               (emit-checkcast +lisp-abstract-vector+)
                (maybe-emit-clear-values arg1 arg2)
                (emit 'swap)
                (emit-invokevirtual +lisp-abstract-vector+
@@ -6346,7 +6362,7 @@
 		       args)))
     (cond ((>= 4 length 1)
 	   (dolist (cons-head cons-heads)
-	     (emit 'new +lisp-cons+)
+	     (emit-new +lisp-cons+)
 	     (emit 'dup)
 	     (compile-form cons-head 'stack nil))
 	   (if list-star-p
@@ -6637,7 +6653,7 @@
     (cond ((and (eq representation :char)
                 (zerop *safety*))
            (compile-form arg1 'stack nil)
-           (emit 'checkcast +lisp-abstract-string+)
+           (emit-checkcast +lisp-abstract-string+)
            (compile-form arg2 'stack :int)
            (maybe-emit-clear-values arg1 arg2)
            (emit-invokevirtual +lisp-abstract-string+ "charAt"
@@ -6648,7 +6664,7 @@
                 (compiler-subtypep type1 'STRING)
                 (fixnum-type-p type2))
            (compile-form arg1 'stack nil)
-           (emit 'checkcast +lisp-abstract-string+)
+           (emit-checkcast +lisp-abstract-string+)
            (compile-form arg2 'stack :int)
            (maybe-emit-clear-values arg1 arg2)
            (emit-invokevirtual +lisp-abstract-string+ "charAt"
@@ -6689,7 +6705,7 @@
                              +lisp-simple-string+
                              +lisp-abstract-string+)))
              (compile-form arg1 'stack nil)
-             (emit 'checkcast class)
+             (emit-checkcast class)
              (compile-form arg2 'stack :int)
              (compile-form arg3 'stack :char)
              (when target
@@ -6792,7 +6808,7 @@
          (:char
           (cond ((compiler-subtypep type1 'string)
                  (compile-form arg1 'stack nil) ; array
-                 (emit 'checkcast +lisp-abstract-string+)
+                 (emit-checkcast +lisp-abstract-string+)
                  (compile-form arg2 'stack :int) ; index
                  (maybe-emit-clear-values arg1 arg2)
                  (emit-invokevirtual +lisp-abstract-string+
@@ -7174,7 +7190,7 @@
               (eq (derive-type (%cadr form)) 'SYMBOL))
          (emit-push-current-thread)
          (compile-form (%cadr form) 'stack nil)
-         (emit 'checkcast +lisp-symbol+)
+         (emit-checkcast +lisp-symbol+)
          (compile-form (%caddr form) 'stack nil)
          (maybe-emit-clear-values (%cadr form) (%caddr form))
          (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
@@ -7326,7 +7342,7 @@
   (let ((arg (%cadr form)))
     (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3))
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
-           (emit 'checkcast +lisp-symbol+)
+           (emit-checkcast +lisp-symbol+)
            (emit-getfield  +lisp-symbol+ "name" +lisp-simple-string+)
            (emit-move-from-stack target representation))
           (t
@@ -7338,7 +7354,7 @@
   (let ((arg (%cadr form)))
     (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3))
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
-           (emit 'checkcast +lisp-symbol+)
+           (emit-checkcast +lisp-symbol+)
            (emit-invokevirtual +lisp-symbol+ "getPackage"
                                nil +lisp-object+)
            (fix-boxing representation nil)
@@ -7352,7 +7368,7 @@
     (let ((arg (%cadr form)))
       (when (eq (derive-compiler-type arg) 'SYMBOL)
 	(compile-forms-and-maybe-emit-clear-values arg 'stack nil)
-        (emit 'checkcast +lisp-symbol+)
+        (emit-checkcast +lisp-symbol+)
         (emit-push-current-thread)
         (emit-invokevirtual +lisp-symbol+ "symbolValue"
                             (list +lisp-thread+) +lisp-object+)
@@ -7381,7 +7397,7 @@
                                            (symbol-name expected-type))))
         (LABEL1 (gensym)))
     (emit 'dup)
-    (emit 'instanceof instanceof-class)
+    (emit-instanceof instanceof-class)
     (emit 'ifne LABEL1)
     (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+)
     (emit-invokestatic +lisp+ "type_error"
@@ -7980,7 +7996,7 @@
           (progn
             ;; if we're the ultimate parent: create the closure array
             (emit-push-constant-int (length *closure-variables*))
-            (emit 'anewarray +lisp-closure-binding+))
+            (emit-anewarray +lisp-closure-binding+))
         (progn
           (aload 0)
           (emit-getfield +lisp-compiled-closure+ "ctx"
@@ -8007,7 +8023,7 @@
             ;; 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-new +lisp-closure-binding+)
             (emit 'dup)
             (cond
               ((null variable)



From ehuelsmann at common-lisp.net  Thu Aug  5 19:16:25 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 05 Aug 2010 15:16:25 -0400
Subject: [armedbear-cvs] r12861 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Oh5vV-0004S1-GE@common-lisp.net>

Author: ehuelsmann
Date: Thu Aug  5 15:16:22 2010
New Revision: 12861

Log:
Add documentation and some TODOs.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Thu Aug  5 15:16:22 2010
@@ -279,12 +279,15 @@
 (defstruct (constant-class (:constructor make-constant-class (index name-index))
                            (:include constant
                                      (tag 7)))
+  "Structure holding information on a 'class' type item in the constant pool."
   name-index)
 
 (defstruct (constant-member-ref (:constructor
                                  %make-constant-member-ref
                                      (tag index class-index name/type-index))
                                 (:include constant))
+  "Structure holding information on a member reference type item
+(a field, method or interface method reference) in the constant pool."
   class-index
   name/type-index)
 
@@ -307,11 +310,14 @@
                              make-constant-string (index value-index))
                             (:include constant
                                       (tag 8)))
+  "Structure holding information on a 'string' type item in the constant pool."
   value-index)
 
 (defstruct (constant-float/int (:constructor
                                 %make-constant-float/int (tag index value))
                                (:include constant))
+  "Structure holding information on a 'float' or 'integer' type item
+in the constant pool."
   value)
 
 (declaim (inline make-constant-float make-constant-int))
@@ -326,6 +332,8 @@
 (defstruct (constant-double/long (:constructor
                                   %make-constant-double/long (tag index value))
                                  (:include constant))
+  "Structure holding information on a 'double' or 'long' type item
+in the constant pool."
   value)
 
 (declaim (inline make-constant-double make-constant-float))
@@ -343,12 +351,18 @@
                                                          descriptor-index))
                                (:include constant
                                          (tag 12)))
+  "Structure holding information on a 'name-and-type' type item in the
+constant pool; this type of element is used by 'member-ref' type items."
   name-index
   descriptor-index)
 
 (defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
                           (:include constant
                                     (tag 1)))
+  "Structure holding information on a 'utf8' type item in the constant pool;
+
+This type of item is used for text representation of identifiers
+and string contents."
   value)
 
 
@@ -488,10 +502,12 @@
 
 (defstruct (class-file (:constructor
                         !make-class-file (class superclass access-flags)))
+  "Holds the components of a class file."
   (constants (make-pool))
   access-flags
   class
   superclass
+  ;; support for implementing interfaces not yet available
   ;; interfaces
   fields
   methods
@@ -689,26 +705,31 @@
           :initial-value 0))
 
 (defstruct (field (:constructor %make-field))
-  ""
+  "Holds information on the properties of fields in the class(-file)."
   access-flags
   name
   descriptor
   attributes)
 
 (defun !make-field (name type &key (flags '(:public)))
-  
+  "Creates a field for addition to a class file."
   (%make-field :access-flags flags
                :name name
                :descriptor type))
 
 (defun field-add-attribute (field attribute)
+  "Adds an attribute to a field."
   (push attribute (field-attributes field)))
 
 (defun field-attribute (field name)
+  "Retrieves an attribute named `name' of `field'.
+
+Returns NIL if the attribute isn't found."
   (find name (field-attributes field)
         :test #'string= :key #'attribute-name))
 
 (defun finalize-field (field class)
+  "Prepares `field' for serialization."
   (let ((pool (class-file-constants class)))
     (setf (field-access-flags field)
           (map-flags (field-access-flags field))
@@ -719,6 +740,7 @@
   (finalize-attributes (field-attributes field) nil class))
 
 (defun !write-field (field stream)
+  "Writes classfile representation of `field' to `stream'."
   (write-u2 (field-access-flags field) stream)
   (write-u2 (field-name field) stream)
   (write-u2 (field-descriptor field) stream)
@@ -726,6 +748,7 @@
 
 
 (defstruct (method (:constructor %!make-method))
+  "Holds information on the properties of methods in the class(-file)."
   access-flags
   name
   descriptor
@@ -747,6 +770,7 @@
     (t name)))
 
 (defun !make-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 name))
@@ -775,11 +799,13 @@
         code)))
 
 (defun method-attribute (method name)
+  "Returns the first attribute of `method' with `name'."
   (find name (method-attributes method)
         :test #'string= :key #'attribute-name))
 
 
 (defun finalize-method (method class)
+  "Prepares `method' for serialization."
   (let ((pool (class-file-constants class)))
     (setf (method-access-flags method)
           (map-flags (method-access-flags method))
@@ -791,6 +817,7 @@
 
 
 (defun !write-method (method stream)
+  "Write class file representation of `method' to `stream'."
   (write-u2 (method-access-flags method) stream)
   (write-u2 (method-name method) stream)
   (sys::%format t "method-name: ~a~%" (method-name method))
@@ -798,6 +825,11 @@
   (write-attributes (method-attributes method) stream))
 
 (defstruct attribute
+  "Parent attribute structure to be included into other attributes, mainly
+to define common fields.
+
+Having common fields allows common driver code for
+finalizing and serializing attributes."
   name
 
   ;; not in the class file:
@@ -806,6 +838,7 @@
   )
 
 (defun finalize-attributes (attributes att class)
+  "Prepare `attributes' (a list) of attribute `att' list for serialization."
   (dolist (attribute attributes)
     ;; assure header: make sure 'name' is in the pool
     (setf (attribute-name attribute)
@@ -815,6 +848,7 @@
     (funcall (attribute-finalizer attribute) attribute att class)))
 
 (defun write-attributes (attributes stream)
+  "Writes the `attributes' to `stream'."
   (write-u2 (length attributes) stream)
   (dolist (attribute attributes)
     (write-u2 (attribute-name attribute) stream)
@@ -834,6 +868,8 @@
                                      (finalizer #'!finalize-code)
                                      (writer #'!write-code))
                            (:constructor %make-code-attribute))
+  "The attribute containing the actual JVM byte code;
+an attribute of a method."
   max-stack
   max-locals
   code
@@ -850,15 +886,18 @@
 
 
 (defun code-label-offset (code label)
+  "Retrieves the `label' offset within a `code' attribute after the
+attribute has been finalized."
   (cdr (assoc label (code-labels code))))
 
 (defun (setf code-label-offset) (offset code label)
+  "Sets the `label' offset within a `code' attribute after the attribute
+has been finalized."
   (setf (code-labels code)
         (acons label offset (code-labels code))))
 
-
-
 (defun !finalize-code (code parent class)
+  "Prepares the `code' attribute for serialization, within method `parent'."
   (declare (ignore parent))
   (let ((c (resolve-instructions (coerce (reverse (code-code code)) 'vector))))
     (setf (code-max-stack code) (analyze-stack c))
@@ -884,6 +923,7 @@
   (finalize-attributes (code-attributes code) code class))
 
 (defun !write-code (code stream)
+  "Writes the attribute `code' to `stream'."
   (sys::%format t "max-stack: ~a~%" (code-max-stack code))
   (write-u2 (code-max-stack code) stream)
   (sys::%format t "max-locals: ~a~%" (code-max-locals code))
@@ -917,11 +957,16 @@
   attribute)
 
 (defun code-attribute (code name)
+  "Returns an attribute of `code' identified by `name'."
   (find name (code-attributes code)
         :test #'string= :key #'attribute-name))
 
 
 (defun code-add-exception-handler (code start end handler type)
+  "Adds an exception handler to `code' protecting the region from
+labels `start' to `end' (inclusive) from exception `type' - where
+a value of NIL indicates all types. Upon an exception of the given
+type, control is transferred to label `handler'."
   (push (make-exception :start-pc start
                         :end-pc end
                         :handler-pc handler
@@ -929,6 +974,9 @@
         (code-exception-handlers code)))
 
 (defstruct exception
+  "Exception handler information.
+
+After finalization, the fields contain offsets instead of labels."
   start-pc    ;; label target
   end-pc      ;; label target
   handler-pc  ;; label target
@@ -973,30 +1021,42 @@
                (restore-code-specials *current-code-attribute*)))))))
 
 
+;; ### Can't be used yet: no serialization
 (defstruct (source-file-attribute (:conc-name source-)
                                   (:include attribute
                                             (name "SourceFile")))
+  "An attribute of the class file indicating which source file
+it was compiled from."
   filename)
 
+;; ### Can't be used yet: no serialization
 (defstruct (line-numbers-attribute (:include attribute
                                              (name "LineNumberTable")))
-  line-numbers)
+  "An attribute of `code-attribute', containing a mapping of offsets
+within the code section to the line numbers in the source file."
+  line-numbers ;; a list of line-number structures, in reverse order
+  )
 
 (defstruct line-number
-  start-pc
+  start-pc  ;; a label, before finalization
   line)
 
+;; ### Can't be used yet: no serialization
 (defstruct (local-variables-attribute (:conc-name local-var-)
                                       (:include attribute
                                                 (name "LocalVariableTable")))
-  locals)
+  "An attribute of the `code-attribute', containing a table of local variable
+names, their type and their scope of validity."
+  locals ;; a list of local-variable structures, in reverse order
+  )
 
 (defstruct (local-variable (:conc-name local-))
-  start-pc
+  start-pc  ;; a label, before finalization
   length
   name
   descriptor
-  index)
+  index ;; The index of the variable inside the block of locals
+  )
 
 #|
 



From ehuelsmann at common-lisp.net  Thu Aug  5 20:20:19 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 05 Aug 2010 16:20:19 -0400
Subject: [armedbear-cvs] r12862 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Oh6vL-0001mR-3n@common-lisp.net>

Author: ehuelsmann
Date: Thu Aug  5 16:20:18 2010
New Revision: 12862

Log:
Implement serialization for SOURCE-FILE-ATTRIBUTE,
LINE-NUMBERS-ATTRIBUTE and LOCAL-VARIABLES-ATTRIBUTE.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Thu Aug  5 16:20:18 2010
@@ -1021,43 +1021,98 @@
                (restore-code-specials *current-code-attribute*)))))))
 
 
-;; ### Can't be used yet: no serialization
 (defstruct (source-file-attribute (:conc-name source-)
                                   (:include attribute
-                                            (name "SourceFile")))
+                                            (name "SourceFile")
+                                            (finalizer #'finalize-source-file)
+                                            (writer #'write-source-file)))
   "An attribute of the class file indicating which source file
 it was compiled from."
   filename)
 
-;; ### Can't be used yet: no serialization
-(defstruct (line-numbers-attribute (:include attribute
-                                             (name "LineNumberTable")))
+(defun finalize-source-file (source-file code class)
+  (declare (ignorable code class))
+  (setf (source-filename source-file)
+        (pool-add-utf8 (class-file-constants class)
+                       (source-filename source-file))))
+
+(defun write-source-file (source-file stream)
+  (write-u2 (source-filename source-file) stream))
+
+
+
+(defstruct (line-numbers-attribute
+             (:conc-name line-numbers-)
+             (:include attribute
+                       (name "LineNumberTable")
+                       (finalizer #'finalize-line-numbers)
+                       (writer #'write-line-numbers)))
   "An attribute of `code-attribute', containing a mapping of offsets
 within the code section to the line numbers in the source file."
-  line-numbers ;; a list of line-number structures, in reverse order
+  table ;; a list of line-number structures, in reverse order
   )
 
 (defstruct line-number
   start-pc  ;; a label, before finalization
   line)
 
-;; ### Can't be used yet: no serialization
-(defstruct (local-variables-attribute (:conc-name local-var-)
-                                      (:include attribute
-                                                (name "LocalVariableTable")))
+(defun finalize-line-numbers (line-numbers code class)
+  (declare (ignorable code class))
+  (dolist (line-number (line-numbers-table line-numbers))
+    (setf (line-number-start-pc line-number)
+          (code-label-offset code (line-number-start-pc line-number)))))
+
+(defun write-line-numbers (line-numbers stream)
+  (write-u2 (length (line-numbers-table line-numbers)) stream)
+  (dolist (line-number (reverse (line-numbers-table line-numbers)))
+    (write-u2 (line-number-start-pc line-number) stream)
+    (write-u2 (line-number-line line-number) stream)))
+
+
+
+(defstruct (local-variables-attribute
+             (:conc-name local-var-)
+             (:include attribute
+                       (name "LocalVariableTable")
+                       (finalizer #'finalize-local-variables)
+                       (writer #'write-local-variables)))
   "An attribute of the `code-attribute', containing a table of local variable
 names, their type and their scope of validity."
-  locals ;; a list of local-variable structures, in reverse order
+  table ;; a list of local-variable structures, in reverse order
   )
 
 (defstruct (local-variable (:conc-name local-))
   start-pc  ;; a label, before finalization
-  length
+  length    ;; a label (at the ending position) before finalization
   name
   descriptor
   index ;; The index of the variable inside the block of locals
   )
 
+(defun finalize-local-variables (local-variables code class)
+  (dolist (local-variable (local-var-table local-variables))
+    (setf (local-start-pc local-variable)
+          (code-label-offset code (local-start-pc local-variable))
+          (local-length local-variable)
+          ;; calculate 'length' from the distance between 2 labels
+          (- (code-label-offset code (local-length local-variable))
+             (local-start-pc local-variable))
+          (local-name local-variable)
+          (pool-add-utf8 (class-file-constants class)
+                         (local-name local-variable))
+          (local-descriptor local-variable)
+          (pool-add-utf8 (class-file-constants class)
+                         (local-descriptor local-variable)))))
+
+(defun write-local-variables (local-variables stream)
+  (write-u2 (length (local-var-table local-variables)) stream)
+  (dolist (local-variable (reverse (local-var-table local-variables)))
+    (write-u2 (local-start-pc local-variable) stream)
+    (write-u2 (local-length local-variable) stream)
+    (write-u2 (local-name local-variable) stream)
+    (write-u2 (local-descriptor local-variable) stream)
+    (write-u2 (local-index local-variable) stream)))
+
 #|
 
 ;; this is the minimal sequence we need to support:



From ehuelsmann at common-lisp.net  Thu Aug  5 20:58:38 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 05 Aug 2010 16:58:38 -0400
Subject: [armedbear-cvs] r12863 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Oh7WQ-0004dC-Uz@common-lisp.net>

Author: ehuelsmann
Date: Thu Aug  5 16:58:38 2010
New Revision: 12863

Log:
Implement CONSTANT-VALUE-ATTRIBUTE, CHECKED-EXCEPTIONS-ATTRIBUTE,
DEPRECATED-ATTRIBUTE and SYNTHETIC-ATTRIBUTE.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Thu Aug  5 16:58:38 2010
@@ -984,6 +984,54 @@
   )
 
 
+(defstruct (constant-value-attribute (:conc-name constant-value-)
+                                     (:include attribute
+                                               (name "ConstantValue")
+                                               ;; finalizer
+                                               ;; writer
+                                               ))
+  "An attribute of a field of primitive type.
+
+"
+  
+  )
+
+
+(defstruct (checked-exceptions-attribute
+             (:conc-name checked-)
+             (:include attribute
+                       (name "Exceptions")
+                       (finalizer #'finalize-checked-exceptions)
+                       (writer #'write-checked-exceptions)))
+  "An attribute of `code-attribute', "
+  table ;; a list of checked classes corresponding to Java's 'throws'
+)
+
+(defun finalize-checked-exceptions (checked-exceptions code class)
+  (declare (ignorable code class))
+
+  "Prepare `checked-exceptions' for serialization."
+  (setf (checked-table checked-exceptions)
+        (mapcar #'(lambda (exception)
+                    (pool-add-class (class-file-constants class)
+                                    exception))
+                (checked-table checked-exceptions))))
+
+(defun write-checked-exceptions (checked-exceptions stream)
+  "Write `checked-exceptions' to `stream' in class file representation."
+  (write-u2 (length (checked-table checked-exceptions)) stream)
+  (dolist (exception (reverse (checked-table checked-exceptions)))
+    (write-u2 exception stream)))
+
+;; Can't be used yet: serialization missing
+(defstruct (deprecated-attribute (:include attribute
+                                           (name "Deprecated")
+                                           (finalizer (constantly nil))
+                                           (writer (constantly nil))))
+  ;; finalizer and writer need to do nothing: Deprecated attributes are empty
+  "An attribute of a class file, field or method, indicating the element
+to which it has been attached has been superseded.")
+
 (defvar *current-code-attribute* nil)
 
 (defun save-code-specials (code)
@@ -1040,6 +1088,14 @@
   (write-u2 (source-filename source-file) stream))
 
 
+(defstruct (synthetic-attribute (:include attribute
+                                          (name "Synthetic")
+                                          (finalizer (constantly nil))
+                                          (writer (constantly nil))))
+  ;; finalizer and writer need to do nothing: Synthetic attributes are empty
+  "An attribute of a class file, field or method to mark that it wasn't
+included in the sources - but was generated artificially.")
+
 
 (defstruct (line-numbers-attribute
              (:conc-name line-numbers-)



From ehuelsmann at common-lisp.net  Fri Aug  6 19:51:50 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 06 Aug 2010 15:51:50 -0400
Subject: [armedbear-cvs] r12864 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhSxK-0003ky-Cb@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug  6 15:51:49 2010
New Revision: 12864

Log:
Rename opcodes.lisp to jvm-instructions.lisp in order to move our
code-emitters layer and resolvers to it.

Added:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
      - copied, changed from r12863, /branches/generic-class-file/abcl/src/org/armedbear/lisp/opcodes.lisp
Removed:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/opcodes.lisp
Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compile-system.lisp	Fri Aug  6 15:51:49 2010
@@ -101,7 +101,7 @@
       (load (do-compile "jvm.lisp"))
       (load (do-compile "source-transform.lisp"))
       (load (do-compile "compiler-macro.lisp"))
-      (load (do-compile "opcodes.lisp"))
+      (load (do-compile "jvm-instructions.lisp"))
       (load (do-compile "setf.lisp"))
       (load (do-compile "extensible-sequences-base.lisp"))
       (load (do-compile "require.lisp"))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug  6 15:51:49 2010
@@ -41,7 +41,7 @@
   (require "KNOWN-FUNCTIONS")
   (require "KNOWN-SYMBOLS")
   (require "DUMP-FORM")
-  (require "OPCODES")
+  (require "JVM-INSTRUCTIONS")
   (require "JAVA"))
 
 

Copied: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp (from r12863, /branches/generic-class-file/abcl/src/org/armedbear/lisp/opcodes.lisp)
==============================================================================
--- /branches/generic-class-file/abcl/src/org/armedbear/lisp/opcodes.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Fri Aug  6 15:51:49 2010
@@ -1,4 +1,4 @@
-;;; opcodes.lisp
+;;; jvm-instructions.lisp
 ;;;
 ;;; Copyright (C) 2003-2006 Peter Graves
 ;;; $Id$

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Aug  6 15:51:49 2010
@@ -43,7 +43,7 @@
   (require "COMPILER-ERROR")
   (require "KNOWN-FUNCTIONS")
   (require "DUMP-FORM")
-  (require "OPCODES")
+  (require "JVM-INSTRUCTIONS")
   (require "JVM-CLASS-FILE")
   (require "KNOWN-SYMBOLS")
   (require "JAVA")



From ehuelsmann at common-lisp.net  Fri Aug  6 20:59:51 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 06 Aug 2010 16:59:51 -0400
Subject: [armedbear-cvs] r12865 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhU19-00082O-GL@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug  6 16:59:50 2010
New Revision: 12865

Log:
Move emit, %emit, %%emit, INSTRUCTION, resolvers and some helper
functions from compiler-pass2.lisp to jvm-instructions.lisp: this
is a step to separate pass2 into several modules.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug  6 16:59:50 2010
@@ -212,83 +212,7 @@
       (code-add-exception-handler *current-code-attribute*
                                   start end handler type)))
 
-(defstruct (instruction (:constructor %make-instruction (opcode args)))
-  (opcode 0 :type (integer 0 255))
-  args
-  stack
-  depth
-  wide)
-
-(defun make-instruction (opcode args)
-  (let ((inst (apply #'%make-instruction
-                     (list opcode
-                           (remove :wide-prefix args)))))
-    (when (memq :wide-prefix args)
-      (setf (inst-wide inst) t))
-    inst))
-
-(defun print-instruction (instruction)
-  (sys::%format nil "~A ~A stack = ~S depth = ~S"
-          (opcode-name (instruction-opcode instruction))
-          (instruction-args instruction)
-          (instruction-stack instruction)
-          (instruction-depth instruction)))
 
-(defknown inst * t)
-(defun inst (instr &optional args)
-  (declare (optimize speed))
-  (let ((opcode (if (fixnump instr)
-                    instr
-                    (opcode-number instr))))
-    (unless (listp args)
-      (setf args (list args)))
-    (make-instruction opcode args)))
-
-(defknown %%emit * t)
-(defun %%emit (instr &rest args)
-  (declare (optimize speed))
-  (let ((instruction (make-instruction instr args)))
-    (push instruction *code*)
-    instruction))
-
-(defknown %emit * t)
-(defun %emit (instr &rest args)
-  (declare (optimize speed))
-  (let ((instruction (inst instr args)))
-    (push instruction *code*)
-    instruction))
-
-(defmacro emit (instr &rest args)
-  (when (and (consp instr) (eq (car instr) 'QUOTE) (symbolp (cadr instr)))
-    (setf instr (opcode-number (cadr instr))))
-  (if (fixnump instr)
-      `(%%emit ,instr , at args)
-      `(%emit ,instr , at args)))
-
-(defknown label (symbol) t)
-(defun label (symbol)
-  (declare (type symbol symbol))
-  (declare (optimize speed))
-  (emit 'label symbol)
-  (setf (symbol-value symbol) nil))
-
-(defknown aload (fixnum) t)
-(defun aload (index)
-  (case index
-    (0 (emit 'aload_0))
-    (1 (emit 'aload_1))
-    (2 (emit 'aload_2))
-    (3 (emit 'aload_3))
-    (t (emit 'aload index))))
-
-(defknown astore (fixnum) t)
-(defun astore (index)
-  (case index
-    (0 (emit 'astore_0))
-    (1 (emit 'astore_1))
-    (2 (emit 'astore_2))
-    (3 (emit 'astore_3))
-    (t (emit 'astore index))))
 
 (defknown emit-push-nil () t)
 (declaim (inline emit-push-nil))
@@ -989,263 +913,6 @@
 (defun check-min-args (form n)
   (check-number-of-args form n t))
 
-(defun unsupported-opcode (instruction)
-  (error "Unsupported opcode ~D." (instruction-opcode instruction)))
-
-(declaim (type hash-table +resolvers+))
-(defconst +resolvers+ (make-hash-table))
-
-(defun initialize-resolvers ()
-  (let ((ht +resolvers+))
-    (dotimes (n (1+ *last-opcode*))
-      (setf (gethash n ht) #'unsupported-opcode))
-    ;; The following opcodes resolve to themselves.
-    (dolist (n '(0 ; nop
-                 1 ; aconst_null
-                 2 ; iconst_m1
-                 3 ; iconst_0
-                 4 ; iconst_1
-                 5 ; iconst_2
-                 6 ; iconst_3
-                 7 ; iconst_4
-                 8 ; iconst_5
-                 9 ; lconst_0
-                 10 ; lconst_1
-                 11 ; fconst_0
-                 12 ; fconst_1
-                 13 ; fconst_2
-                 14 ; dconst_0
-                 15 ; dconst_1
-                 42 ; aload_0
-                 43 ; aload_1
-                 44 ; aload_2
-                 45 ; aload_3
-                 46 ; iaload
-                 47 ; laload
-                 48 ; faload
-                 49 ; daload
-                 50 ; aaload
-                 75 ; astore_0
-                 76 ; astore_1
-                 77 ; astore_2
-                 78 ; astore_3
-                 79 ; iastore
-                 80 ; lastore
-                 81 ; fastore
-                 82 ; dastore
-                 83 ; aastore
-                 87 ; pop
-                 88 ; pop2
-                 89 ; dup
-                 90 ; dup_x1
-                 91 ; dup_x2
-                 92 ; dup2
-                 93 ; dup2_x1
-                 94 ; dup2_x2
-                 95 ; swap
-                 96 ; iadd
-                 97 ; ladd
-                 98 ; fadd
-                 99 ; dadd
-                 100 ; isub
-                 101 ; lsub
-                 102 ; fsub
-                 103 ; dsub
-                 104 ; imul
-                 105 ; lmul
-                 106 ; fmul
-                 107 ; dmul
-                 116 ; ineg
-                 117 ; lneg
-                 118 ; fneg
-                 119 ; dneg
-                 120 ; ishl
-                 121 ; lshl
-                 122 ; ishr
-                 123 ; lshr
-                 126 ; iand
-                 127 ; land
-                 128 ; ior
-                 129 ; lor
-                 130 ; ixor
-                 131 ; lxor
-                 133 ; i2l
-                 134 ; i2f
-                 135 ; i2d
-                 136 ; l2i
-                 137 ; l2f
-                 138 ; l2d
-                 141 ; f2d
-                 144 ; d2f
-                 148 ; lcmp
-                 149 ; fcmpd
-                 150 ; fcmpg
-                 151 ; dcmpd
-                 152 ; dcmpg
-                 153 ; ifeq
-                 154 ; ifne
-                 155 ; ifge
-                 156 ; ifgt
-                 157 ; ifgt
-                 158 ; ifle
-                 159 ; if_icmpeq
-                 160 ; if_icmpne
-                 161 ; if_icmplt
-                 162 ; if_icmpge
-                 163 ; if_icmpgt
-                 164 ; if_icmple
-                 165 ; if_acmpeq
-                 166 ; if_acmpne
-                 167 ; goto
-                 176 ; areturn
-                 177 ; return
-                 190 ; arraylength
-                 191 ; athrow
-                 194 ; monitorenter
-                 195 ; monitorexit
-                 198 ; ifnull
-                 202 ; label
-                 ))
-      (setf (gethash n ht) nil))))
-
-(initialize-resolvers)
-
-(defmacro define-resolver (opcodes args &body body)
-  (let ((name (gensym)))
-    `(progn
-       (defun ,name ,args , at body)
-       (eval-when (:load-toplevel :execute)
-	 ,(if (listp opcodes)
-	      `(dolist (op ',opcodes)
-		 (setf (gethash op +resolvers+) (symbol-function ',name)))
-	      `(setf (gethash ,opcodes +resolvers+) (symbol-function ',name)))))))
-
-(defun load/store-resolver (instruction inst-index inst-index2 error-text)
- (let* ((args (instruction-args instruction))
-        (index (car args)))
-   (declare (type (unsigned-byte 16) index))
-   (cond ((<= 0 index 3)
-          (inst (+ index inst-index)))
-         ((<= 0 index 255)
-          (inst inst-index2 index))
-         (t
-          (error error-text)))))
-
-;; aload
-(define-resolver 25 (instruction)
-  (load/store-resolver instruction 42 25 "ALOAD unsupported case"))
-
-;; astore
-(define-resolver 58 (instruction)
-  (load/store-resolver instruction 75 58 "ASTORE unsupported case"))
-
-;; iload
-(define-resolver 21 (instruction)
-  (load/store-resolver instruction 26 21 "ILOAD unsupported case"))
-
-;; istore
-(define-resolver 54 (instruction)
-  (load/store-resolver instruction 59 54 "ISTORE unsupported case"))
-
-;; lload
-(define-resolver 22 (instruction)
-  (load/store-resolver instruction 30 22 "LLOAD unsupported case"))
-
-;; lstore
-(define-resolver 55 (instruction)
-  (load/store-resolver instruction 63 55 "LSTORE unsupported case"))
-
-;; getstatic, putstatic
-(define-resolver (178 179) (instruction)
-  ;; we used to create the pool-field here; that moved to the emit-* layer
-  instruction)
-
-;; bipush, sipush
-(define-resolver (16 17) (instruction)
-  (let* ((args (instruction-args instruction))
-         (n (first args)))
-    (declare (type fixnum n))
-    (cond ((<= 0 n 5)
-           (inst (+ n 3)))
-          ((<= -128 n 127)
-           (inst 16 (logand n #xff))) ; BIPUSH
-          (t ; SIPUSH
-           (inst 17 (s2 n))))))
-
-;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor
-(define-resolver (182 183 184) (instruction)
-  ;; we used to create the pool-method here; that moved to the emit-* layer
-  instruction)
-
-;; ldc
-(define-resolver 18 (instruction)
-  (let* ((args (instruction-args instruction)))
-    (unless (= (length args) 1)
-      (error "Wrong number of args for LDC."))
-    (if (> (car args) 255)
-        (inst 19 (u2 (car args))) ; LDC_W
-        (inst 18 args))))
-
-;; ldc2_w
-(define-resolver 20 (instruction)
-  (let* ((args (instruction-args instruction)))
-    (unless (= (length args) 1)
-      (error "Wrong number of args for LDC2_W."))
-    (inst 20 (u2 (car args)))))
-
-;; getfield, putfield class-name field-name type-name
-(define-resolver (180 181) (instruction)
-  ;; we used to create the pool-field here; that moved to the emit-* layer
-  instruction)
-
-;; new, anewarray, checkcast, instanceof class-name
-(define-resolver (187 189 192 193) (instruction)
-  ;; we used to create the pool-class here; that moved to the emit-* layer
-  instruction)
-
-;; iinc
-(define-resolver 132 (instruction)
-  (let* ((args (instruction-args instruction))
-         (register (first args))
-         (n (second args)))
-    (when (not (<= -128 n 127))
-      (error "IINC argument ~A out of bounds." n))
-    (inst 132 (list register (s1 n)))))
-
-(defknown resolve-instruction (t) t)
-(defun resolve-instruction (instruction)
-  (declare (optimize speed))
-  (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+)))
-    (if resolver
-        (funcall resolver instruction)
-        instruction)))
-
-(defun resolve-instructions (code)
-  (let* ((len (length code))
-         (vector (make-array (ash len 1) :fill-pointer 0 :adjustable t)))
-    (dotimes (index len vector)
-      (declare (type (unsigned-byte 16) index))
-      (let ((instruction (svref code index)))
-        (case (instruction-opcode instruction)
-          (205 ; CLEAR-VALUES
-           (let ((instructions
-                  (list
-                   (inst 'aload *thread*)
-                   (inst 'aconst_null)
-                   (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
-                                                   +lisp-object-array+))))))
-             (dolist (instruction instructions)
-               (vector-push-extend (resolve-instruction instruction) vector))))
-          (t
-           (vector-push-extend (resolve-instruction instruction) vector)))))))
-
-(declaim (ftype (function (t) t) branch-opcode-p))
-(declaim (inline branch-opcode-p))
-(defun branch-opcode-p (opcode)
-  (declare (optimize speed))
-  (declare (type '(integer 0 255) opcode))
-  (or (<= 153 opcode 168)
-      (= opcode 198)))
 
 (declaim (ftype (function (t t t) t) walk-code))
 (defun walk-code (code start-index depth)
@@ -1318,38 +985,6 @@
 (defun finalize-code ()
   (setf *code* (nreverse (coerce *code* 'vector))))
 
-(defun print-code ()
-  (dotimes (i (length *code*))
-    (let ((instruction (elt *code* i)))
-      (sys::%format t "~D ~A ~S ~S ~S~%"
-                    i
-                    (opcode-name (instruction-opcode instruction))
-                    (instruction-args instruction)
-                    (instruction-stack instruction)
-                    (instruction-depth instruction)))))
-
-(defun print-code2 (code)
-  (dotimes (i (length code))
-    (let ((instruction (elt code i)))
-      (case (instruction-opcode instruction)
-        (202 ; LABEL
-         (format t "~A:~%" (car (instruction-args instruction))))
-        (t
-         (format t "~8D:   ~A ~S~%"
-                 i
-                 (opcode-name (instruction-opcode instruction))
-                 (instruction-args instruction)))))))
-
-(declaim (ftype (function (t) boolean) label-p))
-(defun label-p (instruction)
-  (and instruction
-       (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
-
-(declaim (ftype (function (t) t) instruction-label))
-(defun instruction-label (instruction)
-  (and instruction
-       (= (instruction-opcode (the instruction instruction)) 202)
-       (car (instruction-args instruction))))
 
 ;; Remove unused labels.
 (defun optimize-1 ()
@@ -1526,7 +1161,7 @@
   (when *enable-optimization*
     (when *compiler-debug*
       (format t "----- before optimization -----~%")
-      (print-code))
+      (print-code *code*))
     (loop
       (let ((changed-p nil))
         (setf changed-p (or (optimize-1) changed-p))
@@ -1540,7 +1175,7 @@
       (setf *code* (coerce *code* 'vector)))
     (when *compiler-debug*
       (sys::%format t "----- after optimization -----~%")
-      (print-code)))
+      (print-code *code*)))
   t)
 
 (defun code-bytes (code)
@@ -1853,7 +1488,7 @@
     (setf *code* (append *static-code* *code*))
     (emit 'return)
     (finalize-code)
-    (setf *code* (resolve-instructions *code*))
+    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
     (setf (method-max-stack constructor) (analyze-stack *code*))
     (setf (method-code constructor) (code-bytes *code*))
     (setf (method-handlers constructor) (nreverse *handlers*))
@@ -8153,7 +7788,7 @@
     (finalize-code)
     (optimize-code)
 
-    (setf *code* (resolve-instructions *code*))
+    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
     (setf (method-max-stack execute-method) (analyze-stack *code*))
     (setf (method-code execute-method) (code-bytes *code*))
 

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Fri Aug  6 16:59:50 2010
@@ -31,6 +31,9 @@
 
 (in-package #:jvm)
 
+
+;;    OPCODES
+
 (defconst *opcode-table* (make-array 256))
 
 (defconst *opcodes* (make-hash-table :test 'equalp))
@@ -254,10 +257,10 @@
 (define-opcode ifnonnull 199 3 nil)
 (define-opcode goto_w 200 5 nil)
 (define-opcode jsr_w 201 5 nil)
-(define-opcode label 202 0 0)
+(define-opcode label 202 0 0)  ;; virtual: does not exist in the JVM
 ;; (define-opcode push-value 203 nil 1)
 ;; (define-opcode store-value 204 nil -1)
-(define-opcode clear-values 205 0 0)
+(define-opcode clear-values 205 0 0)  ;; virtual: does not exist in the JVM
 ;;(define-opcode var-ref 206 0 0)
 
 (defparameter *last-opcode* 206)
@@ -286,4 +289,395 @@
   (declare (optimize speed))
   (jvm-opcode-stack-effect (svref *opcode-table* opcode-number)))
 
+
+
+
+;;   INSTRUCTION
+
+(defstruct (instruction (:constructor %make-instruction (opcode args)))
+  (opcode 0 :type (integer 0 255))
+  args
+  stack
+  depth
+  wide)
+
+(defun make-instruction (opcode args)
+  (let ((inst (apply #'%make-instruction
+                     (list opcode
+                           (remove :wide-prefix args)))))
+    (when (memq :wide-prefix args)
+      (setf (inst-wide inst) t))
+    inst))
+
+(defun print-instruction (instruction)
+  (sys::%format nil "~A ~A stack = ~S depth = ~S"
+          (opcode-name (instruction-opcode instruction))
+          (instruction-args instruction)
+          (instruction-stack instruction)
+          (instruction-depth instruction)))
+
+(declaim (ftype (function (t) t) instruction-label))
+(defun instruction-label (instruction)
+  (and instruction
+       (= (instruction-opcode (the instruction instruction)) 202)
+       (car (instruction-args instruction))))
+
+
+
+(defknown inst * t)
+(defun inst (instr &optional args)
+  (declare (optimize speed))
+  (let ((opcode (if (fixnump instr)
+                    instr
+                    (opcode-number instr))))
+    (unless (listp args)
+      (setf args (list args)))
+    (make-instruction opcode args)))
+
+
+;; Having %emit and %%emit output their code to *code*
+;; is currently an implementation detail exposed to all users.
+;; We need to have APIs to address this, but for now pass2 is
+;; our only user and we'll hard-code the use of *code*.
+(defvar *code* nil)
+
+(defknown %%emit * t)
+(defun %%emit (instr &rest args)
+  (declare (optimize speed))
+  (let ((instruction (make-instruction instr args)))
+    (push instruction *code*)
+    instruction))
+
+(defknown %emit * t)
+(defun %emit (instr &rest args)
+  (declare (optimize speed))
+  (let ((instruction (inst instr args)))
+    (push instruction *code*)
+    instruction))
+
+(defmacro emit (instr &rest args)
+  (when (and (consp instr)
+             (eq (car instr) 'QUOTE)
+             (symbolp (cadr instr)))
+    (setf instr (opcode-number (cadr instr))))
+  (if (fixnump instr)
+      `(%%emit ,instr , at args)
+      `(%emit ,instr , at args)))
+
+
+;;  Helper routines
+
+(defknown label (symbol) t)
+(defun label (symbol)
+  (declare (type symbol symbol))
+  (declare (optimize speed))
+  (emit 'label symbol)
+  (setf (symbol-value symbol) nil))
+
+(defknown aload (fixnum) t)
+(defun aload (index)
+  (case index
+    (0 (emit 'aload_0))
+    (1 (emit 'aload_1))
+    (2 (emit 'aload_2))
+    (3 (emit 'aload_3))
+    (t (emit 'aload index))))
+
+(defknown astore (fixnum) t)
+(defun astore (index)
+  (case index
+    (0 (emit 'astore_0))
+    (1 (emit 'astore_1))
+    (2 (emit 'astore_2))
+    (3 (emit 'astore_3))
+    (t (emit 'astore index))))
+
+(declaim (ftype (function (t) t) branch-opcode-p))
+(declaim (inline branch-opcode-p))
+(defun branch-opcode-p (opcode)
+  (declare (optimize speed))
+  (declare (type '(integer 0 255) opcode))
+  (or (<= 153 opcode 168)
+      (= opcode 198)))
+
+(declaim (ftype (function (t) boolean) label-p))
+(defun label-p (instruction)
+  (and instruction
+       (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
+
+(defun print-code (code)
+  (dotimes (i (length code))
+    (let ((instruction (elt code i)))
+      (sys::%format t "~D ~A ~S ~S ~S~%"
+                    i
+                    (opcode-name (instruction-opcode instruction))
+                    (instruction-args instruction)
+                    (instruction-stack instruction)
+                    (instruction-depth instruction)))))
+
+(defun print-code2 (code)
+  (dotimes (i (length code))
+    (let ((instruction (elt code i)))
+      (case (instruction-opcode instruction)
+        (202 ; LABEL
+         (format t "~A:~%" (car (instruction-args instruction))))
+        (t
+         (format t "~8D:   ~A ~S~%"
+                 i
+                 (opcode-name (instruction-opcode instruction))
+                 (instruction-args instruction)))))))
+
+(defun expand-virtual-instructions (code)
+  (let* ((len (length code))
+         (vector (make-array (ash len 1) :fill-pointer 0 :adjustable t)))
+    (dotimes (index len vector)
+      (declare (type (unsigned-byte 16) index))
+      (let ((instruction (svref code index)))
+        (case (instruction-opcode instruction)
+          (205 ; CLEAR-VALUES
+           (dolist (instruction
+                     (list
+                      (inst 'aload *thread*)
+                      (inst 'aconst_null)
+                      (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
+                                                      +lisp-object-array+)))))
+             (vector-push-extend instruction vector)))
+          (t
+           (vector-push-extend instruction vector)))))))
+
+
+;;   RESOLVERS
+
+(defun unsupported-opcode (instruction)
+  (error "Unsupported opcode ~D." (instruction-opcode instruction)))
+
+(declaim (type hash-table +resolvers+))
+(defconst +resolvers+ (make-hash-table))
+
+(defun initialize-resolvers ()
+  (let ((ht +resolvers+))
+    (dotimes (n (1+ *last-opcode*))
+      (setf (gethash n ht) #'unsupported-opcode))
+    ;; The following opcodes resolve to themselves.
+    (dolist (n '(0 ; nop
+                 1 ; aconst_null
+                 2 ; iconst_m1
+                 3 ; iconst_0
+                 4 ; iconst_1
+                 5 ; iconst_2
+                 6 ; iconst_3
+                 7 ; iconst_4
+                 8 ; iconst_5
+                 9 ; lconst_0
+                 10 ; lconst_1
+                 11 ; fconst_0
+                 12 ; fconst_1
+                 13 ; fconst_2
+                 14 ; dconst_0
+                 15 ; dconst_1
+                 42 ; aload_0
+                 43 ; aload_1
+                 44 ; aload_2
+                 45 ; aload_3
+                 46 ; iaload
+                 47 ; laload
+                 48 ; faload
+                 49 ; daload
+                 50 ; aaload
+                 75 ; astore_0
+                 76 ; astore_1
+                 77 ; astore_2
+                 78 ; astore_3
+                 79 ; iastore
+                 80 ; lastore
+                 81 ; fastore
+                 82 ; dastore
+                 83 ; aastore
+                 87 ; pop
+                 88 ; pop2
+                 89 ; dup
+                 90 ; dup_x1
+                 91 ; dup_x2
+                 92 ; dup2
+                 93 ; dup2_x1
+                 94 ; dup2_x2
+                 95 ; swap
+                 96 ; iadd
+                 97 ; ladd
+                 98 ; fadd
+                 99 ; dadd
+                 100 ; isub
+                 101 ; lsub
+                 102 ; fsub
+                 103 ; dsub
+                 104 ; imul
+                 105 ; lmul
+                 106 ; fmul
+                 107 ; dmul
+                 116 ; ineg
+                 117 ; lneg
+                 118 ; fneg
+                 119 ; dneg
+                 120 ; ishl
+                 121 ; lshl
+                 122 ; ishr
+                 123 ; lshr
+                 126 ; iand
+                 127 ; land
+                 128 ; ior
+                 129 ; lor
+                 130 ; ixor
+                 131 ; lxor
+                 133 ; i2l
+                 134 ; i2f
+                 135 ; i2d
+                 136 ; l2i
+                 137 ; l2f
+                 138 ; l2d
+                 141 ; f2d
+                 144 ; d2f
+                 148 ; lcmp
+                 149 ; fcmpd
+                 150 ; fcmpg
+                 151 ; dcmpd
+                 152 ; dcmpg
+                 153 ; ifeq
+                 154 ; ifne
+                 155 ; ifge
+                 156 ; ifgt
+                 157 ; ifgt
+                 158 ; ifle
+                 159 ; if_icmpeq
+                 160 ; if_icmpne
+                 161 ; if_icmplt
+                 162 ; if_icmpge
+                 163 ; if_icmpgt
+                 164 ; if_icmple
+                 165 ; if_acmpeq
+                 166 ; if_acmpne
+                 167 ; goto
+                 176 ; areturn
+                 177 ; return
+                 178 ; getstatic
+                 179 ; putstatic
+                 180 ; getfield
+                 181 ; putfield
+                 182 ; invokevirtual
+                 183 ; invockespecial
+                 184 ; invokestatic
+                 187 ; new
+                 189 ; anewarray
+                 190 ; arraylength
+                 191 ; athrow
+                 192 ; checkcast
+                 193 ; instanceof
+                 194 ; monitorenter
+                 195 ; monitorexit
+                 198 ; ifnull
+                 202 ; label
+                 ))
+      (setf (gethash n ht) nil))))
+
+(initialize-resolvers)
+
+(defmacro define-resolver (opcodes args &body body)
+  (let ((name (gensym)))
+    `(progn
+       (defun ,name ,args , at body)
+       (eval-when (:load-toplevel :execute)
+         ,(if (listp opcodes)
+              `(dolist (op ',opcodes)
+                 (setf (gethash op +resolvers+)
+                       (symbol-function ',name)))
+              `(setf (gethash ,opcodes +resolvers+)
+                     (symbol-function ',name)))))))
+
+(defun load/store-resolver (instruction inst-index inst-index2 error-text)
+ (let* ((args (instruction-args instruction))
+        (index (car args)))
+   (declare (type (unsigned-byte 16) index))
+   (cond ((<= 0 index 3)
+          (inst (+ index inst-index)))
+         ((<= 0 index 255)
+          (inst inst-index2 index))
+         (t
+          (error error-text)))))
+
+;; aload
+(define-resolver 25 (instruction)
+  (load/store-resolver instruction 42 25 "ALOAD unsupported case"))
+
+;; astore
+(define-resolver 58 (instruction)
+  (load/store-resolver instruction 75 58 "ASTORE unsupported case"))
+
+;; iload
+(define-resolver 21 (instruction)
+  (load/store-resolver instruction 26 21 "ILOAD unsupported case"))
+
+;; istore
+(define-resolver 54 (instruction)
+  (load/store-resolver instruction 59 54 "ISTORE unsupported case"))
+
+;; lload
+(define-resolver 22 (instruction)
+  (load/store-resolver instruction 30 22 "LLOAD unsupported case"))
+
+;; lstore
+(define-resolver 55 (instruction)
+  (load/store-resolver instruction 63 55 "LSTORE unsupported case"))
+
+;; bipush, sipush
+(define-resolver (16 17) (instruction)
+  (let* ((args (instruction-args instruction))
+         (n (first args)))
+    (declare (type fixnum n))
+    (cond ((<= 0 n 5)
+           (inst (+ n 3)))
+          ((<= -128 n 127)
+           (inst 16 (logand n #xff))) ; BIPUSH
+          (t ; SIPUSH
+           (inst 17 (s2 n))))))
+
+;; ldc
+(define-resolver 18 (instruction)
+  (let* ((args (instruction-args instruction)))
+    (unless (= (length args) 1)
+      (error "Wrong number of args for LDC."))
+    (if (> (car args) 255)
+        (inst 19 (u2 (car args))) ; LDC_W
+        (inst 18 args))))
+
+;; ldc2_w
+(define-resolver 20 (instruction)
+  (let* ((args (instruction-args instruction)))
+    (unless (= (length args) 1)
+      (error "Wrong number of args for LDC2_W."))
+    (inst 20 (u2 (car args)))))
+
+;; iinc
+(define-resolver 132 (instruction)
+  (let* ((args (instruction-args instruction))
+         (register (first args))
+         (n (second args)))
+    (when (not (<= -128 n 127))
+      (error "IINC argument ~A out of bounds." n))
+    (inst 132 (list register (s1 n)))))
+
+(defknown resolve-instruction (t) t)
+(defun resolve-instruction (instruction)
+  (declare (optimize speed))
+  (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+)))
+    (if resolver
+        (funcall resolver instruction)
+        instruction)))
+
+(defun resolve-instructions (code)
+  (let* ((len (length code))
+         (vector (make-array len :fill-pointer 0 :adjustable t)))
+    (dotimes (index len vector)
+      (declare (type (unsigned-byte 16) index))
+      (let ((instruction (aref code index)))
+        (vector-push-extend (resolve-instruction instruction) vector)))))
+
 (provide '#:opcodes)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Aug  6 16:59:50 2010
@@ -196,8 +196,6 @@
 
 (defvar *this-class* nil)
 
-(defvar *code* ())
-
 ;; All tags visible at the current point of compilation, some of which may not
 ;; be in the current compiland.
 (defvar *visible-tags* ())



From astalla at common-lisp.net  Fri Aug  6 21:47:07 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Fri, 06 Aug 2010 17:47:07 -0400
Subject: [armedbear-cvs] r12866 - in branches/generic-class-file/abcl:
	src/org/armedbear/lisp test/lisp/abcl
Message-ID: <E1OhUkt-0003Pd-Ak@common-lisp.net>

Author: astalla
Date: Fri Aug  6 17:47:06 2010
New Revision: 12866

Log:
WIHT-CODE-TO-METHOD fixes and tests for nesting.


Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
   branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Fri Aug  6 17:47:06 2010
@@ -881,7 +881,7 @@
   ;; labels contains offsets into the code array after it's finalized
   labels ;; an alist
 
-  current-local) ;; used for handling nested WITH-CODE-TO-METHOD blocks
+  (current-local 0)) ;; used for handling nested WITH-CODE-TO-METHOD blocks
 
 
 
@@ -1046,7 +1046,8 @@
         *registers-allocated* (code-max-locals code)
         *register* (code-current-local code)))
 
-(defmacro with-code-to-method ((class-file method &key safe-nesting) &body body)
+(defmacro with-code-to-method ((class-file method &key (safe-nesting t))
+			       &body body)
   (let ((m (gensym))
         (c (gensym)))
     `(progn
@@ -1054,7 +1055,7 @@
            `((when *current-code-attribute*
                (save-code-specials *current-code-attribute*))))
        (let* ((,m ,method)
-              (,c (method-ensure-code method))
+              (,c (method-ensure-code ,method))
               (*pool* (class-file-constants ,class-file))
               (*code* (code-code ,c))
               (*registers-allocated* (code-max-locals ,c))
@@ -1062,6 +1063,7 @@
               (*current-code-attribute* ,c))
          , at body
          (setf (code-code ,c) *code*
+	       (code-current-local ,c) *register*
 ;;               (code-exception-handlers ,c) *handlers*
                (code-max-locals ,c) *registers-allocated*))
        ,@(when safe-nesting

Modified: branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp	(original)
+++ branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp	Fri Aug  6 17:47:06 2010
@@ -319,6 +319,57 @@
           (values (funcall fn) (funcall fn NIL)))))
   NIL T)
 
+;;Nested with-code-to-method
+(deftest with-code-to-method.1
+    (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_6"))
+           (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))
+           (method (jvm::!make-method :class-constructor :void nil
+				      :flags '(:static)))
+	   (registers nil))
+      (jvm::class-add-method file method)
+      (jvm::with-code-to-method (file method)
+	(jvm::allocate-register)
+	(push jvm::*register* registers)
+	(jvm::with-code-to-method (file method)
+	  (jvm::allocate-register)
+	  (push jvm::*register* registers)
+	  (jvm::with-code-to-method (file method)
+	    (jvm::allocate-register)
+	    (push jvm::*register* registers))
+	  (jvm::allocate-register)
+	  (push jvm::*register* registers))
+	(jvm::allocate-register)
+	(push jvm::*register* registers))
+      (jvm::finalize-class-file file)
+      (nreverse registers))
+  (1 2 3 4 5))
+
+(deftest with-code-to-method.2
+    (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_7"))
+           (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))
+           (method1 (jvm::!make-method :class-constructor :void nil
+				       :flags '(:static)))
+	   (method2 (jvm::!make-method "method2" :void nil))
+	   (registers nil))
+      (jvm::class-add-method file method1)
+      (jvm::class-add-method file method2)
+      (jvm::with-code-to-method (file method1)
+	(jvm::allocate-register)
+	(push jvm::*register* registers)
+	(jvm::with-code-to-method (file method2)
+	  (jvm::allocate-register)
+	  (push jvm::*register* registers)
+	  (jvm::with-code-to-method (file method1)
+	    (jvm::allocate-register)
+	    (push jvm::*register* registers))
+	  (jvm::allocate-register)
+	  (push jvm::*register* registers))
+	(jvm::allocate-register)
+	(push jvm::*register* registers))
+      (jvm::finalize-class-file file)
+      (nreverse registers))
+  (1 1 2 2 3))
+
 ;; ;;  generation of an ABCL-like function, with mixed output to constructor,
 ;; ;;  static initializer and function method(s)
 ;; (deftest generate-method.6



From ehuelsmann at common-lisp.net  Fri Aug  6 22:18:07 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 06 Aug 2010 18:18:07 -0400
Subject: [armedbear-cvs] r12867 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhVEt-0005V5-8z@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug  6 18:18:06 2010
New Revision: 12867

Log:
Move and improve ANALYZE-STACK, DELETE-UNREACHABLE-CODE to
jvm-instructions.lisp.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug  6 18:18:06 2010
@@ -914,74 +914,6 @@
   (check-number-of-args form n t))
 
 
-(declaim (ftype (function (t t t) t) walk-code))
-(defun walk-code (code start-index depth)
-  (declare (optimize speed))
-  (declare (type fixnum start-index depth))
-  (do* ((i start-index (1+ i))
-        (limit (length code)))
-       ((>= i limit))
-    (declare (type fixnum i limit))
-    (let* ((instruction (aref code i))
-           (instruction-depth (instruction-depth instruction))
-           (instruction-stack (instruction-stack instruction)))
-      (declare (type fixnum instruction-stack))
-      (when instruction-depth
-        (unless (= (the fixnum instruction-depth) (the fixnum (+ depth instruction-stack)))
-          (internal-compiler-error 
-           "Stack inconsistency detected in ~A at index ~D: found ~S, expected ~S." 
-           (compiland-name *current-compiland*)
-           i instruction-depth (+ depth instruction-stack)))
-        (return-from walk-code))
-      (let ((opcode (instruction-opcode instruction)))
-        (setf depth (+ depth instruction-stack))
-        (setf (instruction-depth instruction) depth)
-        (when (branch-opcode-p opcode)
-          (let ((label (car (instruction-args instruction))))
-            (declare (type symbol label))
-            (walk-code code (symbol-value label) depth)))
-        (when (member opcode '(167 176 191)) ; GOTO ARETURN ATHROW
-          ;; Current path ends.
-          (return-from walk-code))))))
-
-(declaim (ftype (function (t) t) analyze-stack))
-(defun analyze-stack (code)
-  (declare (optimize speed))
-  (let* ((code-length (length code)))
-    (declare (type vector code))
-    (dotimes (i code-length)
-      (declare (type (unsigned-byte 16) i))
-      (let* ((instruction (aref code i))
-             (opcode (instruction-opcode instruction)))
-        (when (eql opcode 202) ; LABEL
-          (let ((label (car (instruction-args instruction))))
-            (set label i)))
-        (if (instruction-stack instruction)
-            (when (opcode-stack-effect opcode)
-              (unless (eql (instruction-stack instruction) (opcode-stack-effect opcode))
-                (sys::%format t "instruction-stack = ~S opcode-stack-effect = ~S~%"
-                         (instruction-stack instruction)
-                         (opcode-stack-effect opcode))
-                (sys::%format t "index = ~D instruction = ~A~%" i (print-instruction instruction))))
-            (setf (instruction-stack instruction) (opcode-stack-effect opcode)))
-        (unless (instruction-stack instruction)
-          (sys::%format t "no stack information for instruction ~D~%" (instruction-opcode instruction))
-          (aver nil))))
-    (walk-code code 0 0)
-    (dolist (handler *handlers*)
-      ;; Stack depth is always 1 when handler is called.
-      (walk-code code (symbol-value (handler-code handler)) 1))
-    (let ((max-stack 0))
-      (declare (type fixnum max-stack))
-      (dotimes (i code-length)
-        (declare (type (unsigned-byte 16) i))
-        (let* ((instruction (aref code i))
-               (instruction-depth (instruction-depth instruction)))
-          (when instruction-depth
-            (setf max-stack (max max-stack (the fixnum instruction-depth))))))
-      max-stack)))
-
-
 (defun finalize-code ()
   (setf *code* (nreverse (coerce *code* 'vector))))
 
@@ -1128,30 +1060,6 @@
       (setf *code* (delete nil code))
       t)))
 
-(defun delete-unreachable-code ()
-  ;; Look for unreachable code after GOTO.
-  (let* ((code (coerce *code* 'vector))
-         (changed nil)
-         (after-goto/areturn nil))
-    (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
-      (let* ((instruction (aref code i))
-             (opcode (instruction-opcode instruction)))
-        (cond (after-goto/areturn
-               (if (= opcode 202) ; LABEL
-                   (setf after-goto/areturn nil)
-                   ;; Unreachable.
-                   (progn
-                     (setf (aref code i) nil)
-                     (setf changed t))))
-              ((= opcode 176) ; ARETURN
-               (setf after-goto/areturn t))
-              ((= opcode 167) ; GOTO
-               (setf after-goto/areturn t)))))
-    (when changed
-      (setf *code* (delete nil code))
-      t)))
-
 (defvar *enable-optimization* t)
 
 (defknown optimize-code () t)
@@ -1168,7 +1076,11 @@
         (setf changed-p (or (optimize-2) changed-p))
         (setf changed-p (or (optimize-2b) changed-p))
         (setf changed-p (or (optimize-3) changed-p))
-        (setf changed-p (or (delete-unreachable-code) changed-p))
+        (if changed-p
+            (setf *code* delete-unreachable-code *code*)
+            (multiple-value-setq
+                (*code* changed-p)
+              (delete-unreachable-code *code*)))
         (unless changed-p
           (return))))
     (unless (vectorp *code*)
@@ -1489,7 +1401,8 @@
     (emit 'return)
     (finalize-code)
     (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
-    (setf (method-max-stack constructor) (analyze-stack *code*))
+    (setf (method-max-stack constructor)
+          (analyze-stack *code* (mapcar #'handler-code *handlers*)))
     (setf (method-code constructor) (code-bytes *code*))
     (setf (method-handlers constructor) (nreverse *handlers*))
     constructor))
@@ -7789,7 +7702,8 @@
     (optimize-code)
 
     (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
-    (setf (method-max-stack execute-method) (analyze-stack *code*))
+    (setf (method-max-stack execute-method)
+          (analyze-stack *code* (mapcar #'handler-code *handlers*)))
     (setf (method-code execute-method) (code-bytes *code*))
 
     ;; Remove handler if its protected range is empty.

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Fri Aug  6 18:18:06 2010
@@ -256,7 +256,7 @@
 (define-opcode ifnull 198 3 -1)
 (define-opcode ifnonnull 199 3 nil)
 (define-opcode goto_w 200 5 nil)
-(define-opcode jsr_w 201 5 nil)
+;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated
 (define-opcode label 202 0 0)  ;; virtual: does not exist in the JVM
 ;; (define-opcode push-value 203 nil 1)
 ;; (define-opcode store-value 204 nil -1)
@@ -392,15 +392,25 @@
     (3 (emit 'astore_3))
     (t (emit 'astore index))))
 
-(declaim (ftype (function (t) t) branch-opcode-p))
-(declaim (inline branch-opcode-p))
-(defun branch-opcode-p (opcode)
+(declaim (ftype (function (t) t) branch-p)
+         (inline branch-p))
+(defun branch-p (opcode)
   (declare (optimize speed))
   (declare (type '(integer 0 255) opcode))
   (or (<= 153 opcode 168)
-      (= opcode 198)))
+      (<= 198 opcode 200))) ;; ifnull / ifnonnull / goto_w
 
-(declaim (ftype (function (t) boolean) label-p))
+(declaim (ftype (function (t) t) unconditional-control-transfer-p)
+         (inline unconditional-control-transfer-p))
+(defun unconditional-control-transfer-p (opcode)
+  (or (= 168 opcode) ;; goto
+      (= 200 opcode) ;; goto_w
+      (<= 172 opcode 177) ;; ?return
+      (= 191 opcode) ;; athrow
+      ))
+
+(declaim (ftype (function (t) boolean) label-p)
+         (inline label-p))
 (defun label-p (instruction)
   (and instruction
        (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
@@ -680,4 +690,107 @@
       (let ((instruction (aref code index)))
         (vector-push-extend (resolve-instruction instruction) vector)))))
 
+
+
+;; BYTE CODE ANALYSIS AND OPTIMIZATION
+
+(declaim (ftype (function (t t t) t) analyze-stack-path))
+(defun analyze-stack-path (code start-index depth)
+  (declare (optimize speed))
+  (declare (type fixnum start-index depth))
+  (do* ((i start-index (1+ i))
+        (limit (length code)))
+       ((>= i limit))
+    (declare (type fixnum i limit))
+    (let* ((instruction (aref code i))
+           (instruction-depth (instruction-depth instruction))
+           (instruction-stack (instruction-stack instruction)))
+      (declare (type fixnum instruction-stack))
+      (when instruction-depth
+        (unless (= (the fixnum instruction-depth)
+                   (the fixnum (+ depth instruction-stack)))
+          (internal-compiler-error "Stack inconsistency detected ~
+                                    in ~A at index ~D: ~
+                                    found ~S, expected ~S."
+                                   (compiland-name *current-compiland*)
+                                   i instruction-depth
+                                   (+ depth instruction-stack)))
+        (return-from analyze-stack-path))
+      (let ((opcode (instruction-opcode instruction)))
+        (setf depth (+ depth instruction-stack))
+        (setf (instruction-depth instruction) depth)
+        (when (branch-opcode-p opcode)
+          (let ((label (car (instruction-args instruction))))
+            (declare (type symbol label))
+            (analyze-stack-path code (symbol-value label) depth)))
+        (when (unconditional-control-transfer-p opcode)
+          ;; Current path ends.
+          (return-from analyze-stack-path))))))
+
+(declaim (ftype (function (t) t) analyze-stack))
+(defun analyze-stack (code exception-entry-points)
+  (declare (optimize speed))
+  (let* ((code-length (length code)))
+    (declare (type vector code))
+    (dotimes (i code-length)
+      (declare (type (unsigned-byte 16) i))
+      (let* ((instruction (aref code i))
+             (opcode (instruction-opcode instruction)))
+        (when (eql opcode 202) ; LABEL
+          (let ((label (car (instruction-args instruction))))
+            (set label i)))
+        (if (instruction-stack instruction)
+            (when (opcode-stack-effect opcode)
+              (unless (eql (instruction-stack instruction)
+                           (opcode-stack-effect opcode))
+                (sys::%format t "instruction-stack = ~S ~
+                                 opcode-stack-effect = ~S~%"
+                              (instruction-stack instruction)
+                              (opcode-stack-effect opcode))
+                (sys::%format t "index = ~D instruction = ~A~%" i
+                              (print-instruction instruction))))
+            (setf (instruction-stack instruction)
+                  (opcode-stack-effect opcode)))
+        (unless (instruction-stack instruction)
+          (sys::%format t "no stack information for instruction ~D~%"
+                        (instruction-opcode instruction))
+          (aver nil))))
+    (analyze-stack-path code 0 0)
+    (dolist (entry-point exception-entry-points)
+      ;; Stack depth is always 1 when handler is called.
+      (analyze-stack-path code (symbol-value entry-point) 1))
+    (let ((max-stack 0))
+      (declare (type fixnum max-stack))
+      (dotimes (i code-length)
+        (declare (type (unsigned-byte 16) i))
+        (let* ((instruction (aref code i))
+               (instruction-depth (instruction-depth instruction)))
+          (when instruction-depth
+            (setf max-stack (max max-stack (the fixnum instruction-depth))))))
+      max-stack)))
+
+(defun delete-unreachable-code (code)
+  ;; Look for unreachable code after GOTO.
+  (let* ((code (coerce code 'vector))
+         (changed nil)
+         (after-goto/areturn nil))
+    (dotimes (i (length code))
+      (declare (type (unsigned-byte 16) i))
+      (let* ((instruction (aref code i))
+             (opcode (instruction-opcode instruction)))
+        (cond (after-goto/areturn
+               (if (= opcode 202) ; LABEL
+                   (setf after-goto/areturn nil)
+                   ;; Unreachable.
+                   (progn
+                     (setf (aref code i) nil)
+                     (setf changed t))))
+              ((unconditional-control-transfer-p opcode)
+               (setf after-goto/areturn t)))))
+    (values (if changed (delete nil code) code)
+            changed)))
+
+
+
+
 (provide '#:opcodes)



From ehuelsmann at common-lisp.net  Fri Aug  6 22:37:17 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 06 Aug 2010 18:37:17 -0400
Subject: [armedbear-cvs] r12868 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhVXR-0006sM-8M@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug  6 18:37:16 2010
New Revision: 12868

Log:
Miscelanious fixes.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug  6 18:37:16 2010
@@ -927,7 +927,7 @@
     (dotimes (i (length code))
       (declare (type (unsigned-byte 16) i))
       (let ((instruction (aref code i)))
-        (when (branch-opcode-p (instruction-opcode instruction))
+        (when (branch-p (instruction-opcode instruction))
           (let ((label (car (instruction-args instruction))))
             (set label marker)))))
     ;; Add labels used for exception handlers.
@@ -1077,7 +1077,7 @@
         (setf changed-p (or (optimize-2b) changed-p))
         (setf changed-p (or (optimize-3) changed-p))
         (if changed-p
-            (setf *code* delete-unreachable-code *code*)
+            (setf *code* (delete-unreachable-code *code*))
             (multiple-value-setq
                 (*code* changed-p)
               (delete-unreachable-code *code*)))
@@ -1112,7 +1112,7 @@
       (dotimes (i (length code))
         (declare (type (unsigned-byte 16) i))
         (let ((instruction (aref code i)))
-          (when (branch-opcode-p (instruction-opcode instruction))
+          (when (branch-p (instruction-opcode instruction))
             (let* ((label (car (instruction-args instruction)))
                    (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index)))
               (setf (instruction-args instruction) (s2 offset))))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Fri Aug  6 18:37:16 2010
@@ -397,13 +397,13 @@
 (defun branch-p (opcode)
   (declare (optimize speed))
   (declare (type '(integer 0 255) opcode))
-  (or (<= 153 opcode 168)
+  (or (<= 153 opcode 167)
       (<= 198 opcode 200))) ;; ifnull / ifnonnull / goto_w
 
 (declaim (ftype (function (t) t) unconditional-control-transfer-p)
          (inline unconditional-control-transfer-p))
 (defun unconditional-control-transfer-p (opcode)
-  (or (= 168 opcode) ;; goto
+  (or (= 167 opcode) ;; goto
       (= 200 opcode) ;; goto_w
       (<= 172 opcode 177) ;; ?return
       (= 191 opcode) ;; athrow
@@ -719,7 +719,7 @@
       (let ((opcode (instruction-opcode instruction)))
         (setf depth (+ depth instruction-stack))
         (setf (instruction-depth instruction) depth)
-        (when (branch-opcode-p opcode)
+        (when (branch-p opcode)
           (let ((label (car (instruction-args instruction))))
             (declare (type symbol label))
             (analyze-stack-path code (symbol-value label) depth)))



From ehuelsmann at common-lisp.net  Sat Aug  7 08:39:51 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 07 Aug 2010 04:39:51 -0400
Subject: [armedbear-cvs] r12869 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhewZ-0006px-J1@common-lisp.net>

Author: ehuelsmann
Date: Sat Aug  7 04:39:49 2010
New Revision: 12869

Log:
Move CODE-BYTES and OPTIMIZE-1 (renamed to DELETE-UNUSED-LABELS)
to jvm-instructions.lisp.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Aug  7 04:39:49 2010
@@ -918,36 +918,6 @@
   (setf *code* (nreverse (coerce *code* 'vector))))
 
 
-;; Remove unused labels.
-(defun optimize-1 ()
-  (let ((code (coerce *code* 'vector))
-        (changed nil)
-        (marker (gensym)))
-    ;; Mark the labels that are actually branched to.
-    (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
-      (let ((instruction (aref code i)))
-        (when (branch-p (instruction-opcode instruction))
-          (let ((label (car (instruction-args instruction))))
-            (set label marker)))))
-    ;; Add labels used for exception handlers.
-    (dolist (handler *handlers*)
-      (set (handler-from handler) marker)
-      (set (handler-to handler) marker)
-      (set (handler-code handler) marker))
-    ;; Remove labels that are not used as branch targets.
-    (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
-      (let ((instruction (aref code i)))
-        (when (= (instruction-opcode instruction) 202) ; LABEL
-          (let ((label (car (instruction-args instruction))))
-            (declare (type symbol label))
-            (unless (eq (symbol-value label) marker)
-              (setf (aref code i) nil)
-              (setf changed t))))))
-    (when changed
-      (setf *code* (delete nil code))
-      t)))
 
 (defun optimize-2 ()
   (let* ((code (coerce *code* 'vector))
@@ -1072,7 +1042,13 @@
       (print-code *code*))
     (loop
       (let ((changed-p nil))
-        (setf changed-p (or (optimize-1) changed-p))
+        (multiple-value-setq
+            (*code* changed-p)
+          (delete-unused-labels *code*
+                                (append
+                                 (mapcar #'handler-from *handlers*)
+                                 (mapcar #'handler-to *handlers*)
+                                 (mapcar #'handler-code *handlers*))))
         (setf changed-p (or (optimize-2) changed-p))
         (setf changed-p (or (optimize-2b) changed-p))
         (setf changed-p (or (optimize-3) changed-p))
@@ -1090,48 +1066,6 @@
       (print-code *code*)))
   t)
 
-(defun code-bytes (code)
-  (let ((length 0)
-        labels ;; alist
-        )
-    (declare (type (unsigned-byte 16) length))
-    ;; Pass 1: calculate label offsets and overall length.
-    (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
-      (let* ((instruction (aref code i))
-             (opcode (instruction-opcode instruction)))
-        (if (= opcode 202) ; LABEL
-            (let ((label (car (instruction-args instruction))))
-              (set label length)
-              (setf labels
-                    (acons label length labels)))
-            (incf length (opcode-size opcode)))))
-    ;; Pass 2: replace labels with calculated offsets.
-    (let ((index 0))
-      (declare (type (unsigned-byte 16) index))
-      (dotimes (i (length code))
-        (declare (type (unsigned-byte 16) i))
-        (let ((instruction (aref code i)))
-          (when (branch-p (instruction-opcode instruction))
-            (let* ((label (car (instruction-args instruction)))
-                   (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index)))
-              (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.
-    (let ((bytes (make-array length))
-          (index 0))
-      (declare (type (unsigned-byte 16) index))
-      (dotimes (i (length code))
-        (declare (type (unsigned-byte 16) i))
-        (let ((instruction (aref code i)))
-          (unless (= (instruction-opcode instruction) 202) ; LABEL
-            (setf (svref bytes index) (instruction-opcode instruction))
-            (incf index)
-            (dolist (byte (instruction-args instruction))
-              (setf (svref bytes index) byte)
-              (incf index)))))
-      (values bytes labels))))
 
 (declaim (inline write-u1))
 (defun write-u1 (n stream)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Sat Aug  7 04:39:49 2010
@@ -769,6 +769,34 @@
             (setf max-stack (max max-stack (the fixnum instruction-depth))))))
       max-stack)))
 
+
+(defun delete-unused-labels (code handler-labels)
+  (let ((code (coerce code 'vector))
+        (changed nil)
+        (marker (gensym)))
+    ;; Mark the labels that are actually branched to.
+    (dotimes (i (length code))
+      (declare (type (unsigned-byte 16) i))
+      (let ((instruction (aref code i)))
+        (when (branch-p (instruction-opcode instruction))
+          (let ((label (car (instruction-args instruction))))
+            (set label marker)))))
+    ;; Add labels used for exception handlers.
+    (dolist (label handler-labels)
+      (set label marker))
+    ;; Remove labels that are not used as branch targets.
+    (dotimes (i (length code))
+      (declare (type (unsigned-byte 16) i))
+      (let ((instruction (aref code i)))
+        (when (= (instruction-opcode instruction) 202) ; LABEL
+          (let ((label (car (instruction-args instruction))))
+            (declare (type symbol label))
+            (unless (eq (symbol-value label) marker)
+              (setf (aref code i) nil)
+              (setf changed t))))))
+    (values (if changed (delete nil code) code)
+            changed)))
+
 (defun delete-unreachable-code (code)
   ;; Look for unreachable code after GOTO.
   (let* ((code (coerce code 'vector))
@@ -790,6 +818,50 @@
     (values (if changed (delete nil code) code)
             changed)))
 
+(defun code-bytes (code)
+  (let ((length 0)
+        labels ;; alist
+        )
+    (declare (type (unsigned-byte 16) length))
+    ;; Pass 1: calculate label offsets and overall length.
+    (dotimes (i (length code))
+      (declare (type (unsigned-byte 16) i))
+      (let* ((instruction (aref code i))
+             (opcode (instruction-opcode instruction)))
+        (if (= opcode 202) ; LABEL
+            (let ((label (car (instruction-args instruction))))
+              (set label length)
+              (setf labels
+                    (acons label length labels)))
+            (incf length (opcode-size opcode)))))
+    ;; Pass 2: replace labels with calculated offsets.
+    (let ((index 0))
+      (declare (type (unsigned-byte 16) index))
+      (dotimes (i (length code))
+        (declare (type (unsigned-byte 16) i))
+        (let ((instruction (aref code i)))
+          (when (branch-p (instruction-opcode instruction))
+            (let* ((label (car (instruction-args instruction)))
+                   (offset (- (the (unsigned-byte 16)
+                                (symbol-value (the symbol label)))
+                              index)))
+              (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.
+    (let ((bytes (make-array length))
+          (index 0))
+      (declare (type (unsigned-byte 16) index))
+      (dotimes (i (length code))
+        (declare (type (unsigned-byte 16) i))
+        (let ((instruction (aref code i)))
+          (unless (= (instruction-opcode instruction) 202) ; LABEL
+            (setf (svref bytes index) (instruction-opcode instruction))
+            (incf index)
+            (dolist (byte (instruction-args instruction))
+              (setf (svref bytes index) byte)
+              (incf index)))))
+      (values bytes labels))))
 
 
 



From ehuelsmann at common-lisp.net  Sat Aug  7 10:14:33 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 07 Aug 2010 06:14:33 -0400
Subject: [armedbear-cvs] r12870 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhgQD-0006AZ-0o@common-lisp.net>

Author: ehuelsmann
Date: Sat Aug  7 06:14:30 2010
New Revision: 12870

Log:
Move OPTIMIZE-2B (renaming it to OPTIMIZE-JUMPS)
to jvm-instructions.lisp.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Aug  7 06:14:30 2010
@@ -963,48 +963,6 @@
       (setf *code* (delete nil code))
       t)))
 
-(declaim (ftype (function (t) hash-table) hash-labels))
-(defun hash-labels (code)
-  (let ((ht (make-hash-table :test 'eq))
-        (code (coerce code 'vector))
-        (pending-labels '()))
-    (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
-      (let ((instruction (aref code i)))
-        (cond ((label-p instruction)
-               (push (instruction-label instruction) pending-labels))
-              (t
-               ;; Not a label.
-               (when pending-labels
-                 (dolist (label pending-labels)
-                   (setf (gethash label ht) instruction))
-                 (setf pending-labels nil))))))
-    ht))
-
-(defun optimize-2b ()
-  (let* ((code (coerce *code* 'vector))
-         (ht (hash-labels code))
-         (changed nil))
-    (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
-      (let ((instruction (aref code i)))
-        (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
-          (let* ((target-label (car (instruction-args instruction)))
-                 (next-instruction (gethash1 target-label ht)))
-            (when next-instruction
-              (case (instruction-opcode next-instruction)
-                (167 ; GOTO
-                 (setf (instruction-args instruction)
-                       (instruction-args next-instruction)
-                       changed t))
-                (176 ; ARETURN
-                 (setf (instruction-opcode instruction) 176
-                       (instruction-args instruction) nil
-                       changed t))))))))
-    (when changed
-      (setf *code* code)
-      t)))
-
 ;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
 ;; GETSTATIC POP => nothing
 (defun optimize-3 ()
@@ -1045,12 +1003,16 @@
         (multiple-value-setq
             (*code* changed-p)
           (delete-unused-labels *code*
-                                (append
+                                (nconc
                                  (mapcar #'handler-from *handlers*)
                                  (mapcar #'handler-to *handlers*)
                                  (mapcar #'handler-code *handlers*))))
         (setf changed-p (or (optimize-2) changed-p))
-        (setf changed-p (or (optimize-2b) changed-p))
+        (if changed-p
+            (setf *code* (optimize-jumps *code*))
+            (multiple-value-setq
+                (*code* changed-p)
+              (optimize-jumps *code*)))
         (setf changed-p (or (optimize-3) changed-p))
         (if changed-p
             (setf *code* (delete-unreachable-code *code*))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Sat Aug  7 06:14:30 2010
@@ -818,6 +818,48 @@
     (values (if changed (delete nil code) code)
             changed)))
 
+
+(declaim (ftype (function (t) hash-table) hash-labels))
+(defun label-target-instructions (code)
+  (let ((ht (make-hash-table :test 'eq))
+        (code (coerce code 'vector))
+        (pending-labels '()))
+    (dotimes (i (length code))
+      (declare (type (unsigned-byte 16) i))
+      (let ((instruction (aref code i)))
+        (cond ((label-p instruction)
+               (push (instruction-label instruction) pending-labels))
+              (t
+               ;; Not a label.
+               (when pending-labels
+                 (dolist (label pending-labels)
+                   (setf (gethash label ht) instruction))
+                 (setf pending-labels nil))))))
+    ht))
+
+(defun optimize-jumps (code)
+  (let* ((code (coerce code 'vector))
+         (ht (label-target-instructions code))
+         (changed nil))
+    (dotimes (i (length code))
+      (declare (type (unsigned-byte 16) i))
+      (let ((instruction (aref code i)))
+        (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
+          ;; we're missing conditional jumps here?
+          (let* ((target-label (car (instruction-args instruction)))
+                 (next-instruction (gethash1 target-label ht)))
+            (when next-instruction
+              (case (instruction-opcode next-instruction)
+                ((167 200)                  ;; GOTO
+                 (setf (instruction-args instruction)
+                       (instruction-args next-instruction)
+                       changed t))
+                (176 ; ARETURN
+                 (setf (instruction-opcode instruction) 176
+                       (instruction-args instruction) nil
+                       changed t))))))))
+    (values code changed)))
+
 (defun code-bytes (code)
   (let ((length 0)
         labels ;; alist



From ehuelsmann at common-lisp.net  Sat Aug  7 11:53:25 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 07 Aug 2010 07:53:25 -0400
Subject: [armedbear-cvs] r12871 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ohhxt-0004pd-Lr@common-lisp.net>

Author: ehuelsmann
Date: Sat Aug  7 07:53:23 2010
New Revision: 12871

Log:
Eliminate optimize-2: Partially, it duplicated DELETE-UNREACHABLE-CODE.
The other part moves to OPTIMIZE-3.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Aug  7 07:53:23 2010
@@ -918,51 +918,6 @@
   (setf *code* (nreverse (coerce *code* 'vector))))
 
 
-
-(defun optimize-2 ()
-  (let* ((code (coerce *code* 'vector))
-         (length (length code))
-         (changed nil))
-    (declare (type (unsigned-byte 16) length))
-    ;; Since we're looking at this instruction and the next one, we can stop
-    ;; one before the end.
-    (dotimes (i (1- length))
-      (declare (type (unsigned-byte 16) i))
-      (let ((instruction (aref code i)))
-        (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
-          (do* ((j (1+ i) (1+ j))
-                (next-instruction (aref code j) (aref code j)))
-               ((>= j length))
-            (declare (type (unsigned-byte 16) j))
-            (when next-instruction
-              (cond ((= (instruction-opcode next-instruction) 167) ; GOTO
-                     (cond ((= j (1+ i))
-                            ;; Two GOTOs in a row: the second instruction is
-                            ;; unreachable.
-                            (setf (aref code j) nil)
-                            (setf changed t))
-                           ((eq (car (instruction-args next-instruction))
-                                (car (instruction-args instruction)))
-                            ;; We've reached another GOTO to the same destination.
-                            ;; We don't need the first GOTO; we can just fall
-                            ;; through to the second one.
-                            (setf (aref code i) nil)
-                            (setf changed t)))
-                     (return))
-                    ((= (instruction-opcode next-instruction) 202) ; LABEL
-                     (when (eq (car (instruction-args instruction))
-                               (car (instruction-args next-instruction)))
-                       ;; GOTO next instruction; we don't need this one.
-                       (setf (aref code i) nil)
-                       (setf changed t)
-                       (return)))
-                    (t
-                     ;; Not a GOTO or a label.
-                     (return))))))))
-    (when changed
-      (setf *code* (delete nil code))
-      t)))
-
 ;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
 ;; GETSTATIC POP => nothing
 (defun optimize-3 ()
@@ -971,9 +926,11 @@
     (dotimes (i (1- (length code)))
       (declare (type (unsigned-byte 16) i))
       (let* ((this-instruction (aref code i))
-             (this-opcode (and this-instruction (instruction-opcode this-instruction)))
+             (this-opcode (and this-instruction
+                               (instruction-opcode this-instruction)))
              (next-instruction (aref code (1+ i)))
-             (next-opcode (and next-instruction (instruction-opcode next-instruction))))
+             (next-opcode (and next-instruction
+                               (instruction-opcode next-instruction))))
         (case this-opcode
           (205 ; CLEAR-VALUES
            (when (eql next-opcode 205) ; CLEAR-VALUES
@@ -983,6 +940,13 @@
            (when (eql next-opcode 87) ; POP
              (setf (aref code i) nil)
              (setf (aref code (1+ i)) nil)
+             (setf changed t)))
+          (167 ; GOTO
+           (when (and (eql next-opcode 202)  ; LABEL
+                      (eq (car (instruction-args this-instruction))
+                          (car (instruction-args next-instruction))))
+             (setf (aref code i) nil)
+             ;;(setf (aref code (1+ i)) nil)
              (setf changed t))))))
     (when changed
       (setf *code* (delete nil code))
@@ -1007,7 +971,6 @@
                                  (mapcar #'handler-from *handlers*)
                                  (mapcar #'handler-to *handlers*)
                                  (mapcar #'handler-code *handlers*))))
-        (setf changed-p (or (optimize-2) changed-p))
         (if changed-p
             (setf *code* (optimize-jumps *code*))
             (multiple-value-setq



From ehuelsmann at common-lisp.net  Sat Aug  7 12:30:06 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 07 Aug 2010 08:30:06 -0400
Subject: [armedbear-cvs] r12872 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhiXO-0001nV-Ak@common-lisp.net>

Author: ehuelsmann
Date: Sat Aug  7 08:30:05 2010
New Revision: 12872

Log:
In OPTIMIZE-3, do not consider LABELs a 'next instruction',
skip them instead.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Aug  7 08:30:05 2010
@@ -928,7 +928,14 @@
       (let* ((this-instruction (aref code i))
              (this-opcode (and this-instruction
                                (instruction-opcode this-instruction)))
-             (next-instruction (aref code (1+ i)))
+             (labels-skipped-p nil)
+             (next-instruction (do ((j (1+ i) (1+ j)))
+                                   ((or (>= j (length code))
+                                        (/= 202 ; LABEL
+                                            (instruction-opcode (aref code j))))
+                                    (when (< j (length code))
+                                      (aref code j)))
+                                 (setf labels-skipped-p t)))
              (next-opcode (and next-instruction
                                (instruction-opcode next-instruction))))
         (case this-opcode
@@ -937,7 +944,8 @@
              (setf (aref code i) nil)
              (setf changed t)))
           (178 ; GETSTATIC
-           (when (eql next-opcode 87) ; POP
+           (when (and (eql next-opcode 87) ; POP
+                      (not labels-skipped-p))
              (setf (aref code i) nil)
              (setf (aref code (1+ i)) nil)
              (setf changed t)))
@@ -946,7 +954,6 @@
                       (eq (car (instruction-args this-instruction))
                           (car (instruction-args next-instruction))))
              (setf (aref code i) nil)
-             ;;(setf (aref code (1+ i)) nil)
              (setf changed t))))))
     (when changed
       (setf *code* (delete nil code))



From ehuelsmann at common-lisp.net  Sat Aug  7 20:41:24 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 07 Aug 2010 16:41:24 -0400
Subject: [armedbear-cvs] r12873 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhqCq-0004sb-9s@common-lisp.net>

Author: ehuelsmann
Date: Sat Aug  7 16:41:22 2010
New Revision: 12873

Log:
In OPTIMIZE-JUMPS, optimize conditional jumps as well as
unconditional ones.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Sat Aug  7 16:41:22 2010
@@ -395,8 +395,8 @@
 (declaim (ftype (function (t) t) branch-p)
          (inline branch-p))
 (defun branch-p (opcode)
-  (declare (optimize speed))
-  (declare (type '(integer 0 255) opcode))
+;;  (declare (optimize speed))
+;;  (declare (type '(integer 0 255) opcode))
   (or (<= 153 opcode 167)
       (<= 198 opcode 200))) ;; ifnull / ifnonnull / goto_w
 
@@ -843,9 +843,9 @@
          (changed nil))
     (dotimes (i (length code))
       (declare (type (unsigned-byte 16) i))
-      (let ((instruction (aref code i)))
-        (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
-          ;; we're missing conditional jumps here?
+      (let* ((instruction (aref code i))
+             (opcode (and instruction (instruction-opcode instruction))))
+        (when (and opcode (branch-p opcode))
           (let* ((target-label (car (instruction-args instruction)))
                  (next-instruction (gethash1 target-label ht)))
             (when next-instruction
@@ -855,9 +855,10 @@
                        (instruction-args next-instruction)
                        changed t))
                 (176 ; ARETURN
-                 (setf (instruction-opcode instruction) 176
-                       (instruction-args instruction) nil
-                       changed t))))))))
+                 (when (unconditional-control-transfer-p opcode)
+                   (setf (instruction-opcode instruction) 176
+                         (instruction-args instruction) nil
+                         changed t)))))))))
     (values code changed)))
 
 (defun code-bytes (code)



From ehuelsmann at common-lisp.net  Sat Aug  7 20:43:46 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 07 Aug 2010 16:43:46 -0400
Subject: [armedbear-cvs] r12874 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhqF8-0004wX-Su@common-lisp.net>

Author: ehuelsmann
Date: Sat Aug  7 16:43:45 2010
New Revision: 12874

Log:
Rename OPTIMIZE-3 to OPTIMIZE-INSTRUCTION-SEQUENCES
and optimize more sequences.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Aug  7 16:43:45 2010
@@ -918,10 +918,8 @@
   (setf *code* (nreverse (coerce *code* 'vector))))
 
 
-;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
-;; GETSTATIC POP => nothing
-(defun optimize-3 ()
-  (let* ((code (coerce *code* 'vector))
+(defun optimize-instruction-sequences (code)
+  (let* ((code (coerce code 'vector))
          (changed nil))
     (dotimes (i (1- (length code)))
       (declare (type (unsigned-byte 16) i))
@@ -940,24 +938,29 @@
                                (instruction-opcode next-instruction))))
         (case this-opcode
           (205 ; CLEAR-VALUES
-           (when (eql next-opcode 205) ; CLEAR-VALUES
+           (when (eql next-opcode 205)       ; CLEAR-VALUES
              (setf (aref code i) nil)
              (setf changed t)))
           (178 ; GETSTATIC
-           (when (and (eql next-opcode 87) ; POP
+           (when (and (eql next-opcode 87)   ; POP
                       (not labels-skipped-p))
              (setf (aref code i) nil)
              (setf (aref code (1+ i)) nil)
              (setf changed t)))
-          (167 ; GOTO
-           (when (and (eql next-opcode 202)  ; LABEL
+          (176 ; ARETURN
+           (when (eql next-opcode 176)       ; ARETURN
+             (setf (aref code i) nil)
+             (setf changed t)))
+          ((200 167)                         ; GOTO GOTO_W
+           (when (and (or (eql next-opcode 202)  ; LABEL
+                          (eql next-opcode 200)  ; GOTO_W
+                          (eql next-opcode 167)) ; GOTO
                       (eq (car (instruction-args this-instruction))
                           (car (instruction-args next-instruction))))
              (setf (aref code i) nil)
              (setf changed t))))))
-    (when changed
-      (setf *code* (delete nil code))
-      t)))
+    (values (if changed (delete nil code) code)
+            changed)))
 
 (defvar *enable-optimization* t)
 
@@ -979,11 +982,15 @@
                                  (mapcar #'handler-to *handlers*)
                                  (mapcar #'handler-code *handlers*))))
         (if changed-p
+            (setf *code* (optimize-instruction-sequences *code*))
+            (multiple-value-setq
+                (*code* changed-p)
+              (optimize-instruction-sequences *code*)))
+        (if changed-p
             (setf *code* (optimize-jumps *code*))
             (multiple-value-setq
                 (*code* changed-p)
               (optimize-jumps *code*)))
-        (setf changed-p (or (optimize-3) changed-p))
         (if changed-p
             (setf *code* (delete-unreachable-code *code*))
             (multiple-value-setq



From ehuelsmann at common-lisp.net  Sat Aug  7 21:14:08 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sat, 07 Aug 2010 17:14:08 -0400
Subject: [armedbear-cvs] r12875 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OhqiV-000702-VO@common-lisp.net>

Author: ehuelsmann
Date: Sat Aug  7 17:14:06 2010
New Revision: 12875

Log:
Move OPTIMIZE-INSTRUCTION-SEQUENCES and OPTIMIZE-CODE
to jvm-instructions.lisp.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Aug  7 17:14:06 2010
@@ -918,92 +918,6 @@
   (setf *code* (nreverse (coerce *code* 'vector))))
 
 
-(defun optimize-instruction-sequences (code)
-  (let* ((code (coerce code 'vector))
-         (changed nil))
-    (dotimes (i (1- (length code)))
-      (declare (type (unsigned-byte 16) i))
-      (let* ((this-instruction (aref code i))
-             (this-opcode (and this-instruction
-                               (instruction-opcode this-instruction)))
-             (labels-skipped-p nil)
-             (next-instruction (do ((j (1+ i) (1+ j)))
-                                   ((or (>= j (length code))
-                                        (/= 202 ; LABEL
-                                            (instruction-opcode (aref code j))))
-                                    (when (< j (length code))
-                                      (aref code j)))
-                                 (setf labels-skipped-p t)))
-             (next-opcode (and next-instruction
-                               (instruction-opcode next-instruction))))
-        (case this-opcode
-          (205 ; CLEAR-VALUES
-           (when (eql next-opcode 205)       ; CLEAR-VALUES
-             (setf (aref code i) nil)
-             (setf changed t)))
-          (178 ; GETSTATIC
-           (when (and (eql next-opcode 87)   ; POP
-                      (not labels-skipped-p))
-             (setf (aref code i) nil)
-             (setf (aref code (1+ i)) nil)
-             (setf changed t)))
-          (176 ; ARETURN
-           (when (eql next-opcode 176)       ; ARETURN
-             (setf (aref code i) nil)
-             (setf changed t)))
-          ((200 167)                         ; GOTO GOTO_W
-           (when (and (or (eql next-opcode 202)  ; LABEL
-                          (eql next-opcode 200)  ; GOTO_W
-                          (eql next-opcode 167)) ; GOTO
-                      (eq (car (instruction-args this-instruction))
-                          (car (instruction-args next-instruction))))
-             (setf (aref code i) nil)
-             (setf changed t))))))
-    (values (if changed (delete nil code) code)
-            changed)))
-
-(defvar *enable-optimization* t)
-
-(defknown optimize-code () t)
-(defun optimize-code ()
-  (unless *enable-optimization*
-    (format t "optimizations are disabled~%"))
-  (when *enable-optimization*
-    (when *compiler-debug*
-      (format t "----- before optimization -----~%")
-      (print-code *code*))
-    (loop
-      (let ((changed-p nil))
-        (multiple-value-setq
-            (*code* changed-p)
-          (delete-unused-labels *code*
-                                (nconc
-                                 (mapcar #'handler-from *handlers*)
-                                 (mapcar #'handler-to *handlers*)
-                                 (mapcar #'handler-code *handlers*))))
-        (if changed-p
-            (setf *code* (optimize-instruction-sequences *code*))
-            (multiple-value-setq
-                (*code* changed-p)
-              (optimize-instruction-sequences *code*)))
-        (if changed-p
-            (setf *code* (optimize-jumps *code*))
-            (multiple-value-setq
-                (*code* changed-p)
-              (optimize-jumps *code*)))
-        (if changed-p
-            (setf *code* (delete-unreachable-code *code*))
-            (multiple-value-setq
-                (*code* changed-p)
-              (delete-unreachable-code *code*)))
-        (unless changed-p
-          (return))))
-    (unless (vectorp *code*)
-      (setf *code* (coerce *code* 'vector)))
-    (when *compiler-debug*
-      (sys::%format t "----- after optimization -----~%")
-      (print-code *code*)))
-  t)
 
 
 (declaim (inline write-u1))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Sat Aug  7 17:14:06 2010
@@ -861,6 +861,97 @@
                          changed t)))))))))
     (values code changed)))
 
+
+(defun optimize-instruction-sequences (code)
+  (let* ((code (coerce code 'vector))
+         (changed nil))
+    (dotimes (i (1- (length code)))
+      (declare (type (unsigned-byte 16) i))
+      (let* ((this-instruction (aref code i))
+             (this-opcode (and this-instruction
+                               (instruction-opcode this-instruction)))
+             (labels-skipped-p nil)
+             (next-instruction (do ((j (1+ i) (1+ j)))
+                                   ((or (>= j (length code))
+                                        (/= 202 ; LABEL
+                                            (instruction-opcode (aref code j))))
+                                    (when (< j (length code))
+                                      (aref code j)))
+                                 (setf labels-skipped-p t)))
+             (next-opcode (and next-instruction
+                               (instruction-opcode next-instruction))))
+        (case this-opcode
+          (205 ; CLEAR-VALUES
+           (when (eql next-opcode 205)       ; CLEAR-VALUES
+             (setf (aref code i) nil)
+             (setf changed t)))
+          (178 ; GETSTATIC
+           (when (and (eql next-opcode 87)   ; POP
+                      (not labels-skipped-p))
+             (setf (aref code i) nil)
+             (setf (aref code (1+ i)) nil)
+             (setf changed t)))
+          (176 ; ARETURN
+           (when (eql next-opcode 176)       ; ARETURN
+             (setf (aref code i) nil)
+             (setf changed t)))
+          ((200 167)                         ; GOTO GOTO_W
+           (when (and (or (eql next-opcode 202)  ; LABEL
+                          (eql next-opcode 200)  ; GOTO_W
+                          (eql next-opcode 167)) ; GOTO
+                      (eq (car (instruction-args this-instruction))
+                          (car (instruction-args next-instruction))))
+             (setf (aref code i) nil)
+             (setf changed t))))))
+    (values (if changed (delete nil code) code)
+            changed)))
+
+(defvar *enable-optimization* t)
+
+(defknown optimize-code () t)
+(defun optimize-code ()
+  (unless *enable-optimization*
+    (format t "optimizations are disabled~%"))
+  (when *enable-optimization*
+    (when *compiler-debug*
+      (format t "----- before optimization -----~%")
+      (print-code *code*))
+    (loop
+      (let ((changed-p nil))
+        (multiple-value-setq
+            (*code* changed-p)
+          (delete-unused-labels *code*
+                                (nconc
+                                 (mapcar #'handler-from *handlers*)
+                                 (mapcar #'handler-to *handlers*)
+                                 (mapcar #'handler-code *handlers*))))
+        (if changed-p
+            (setf *code* (optimize-instruction-sequences *code*))
+            (multiple-value-setq
+                (*code* changed-p)
+              (optimize-instruction-sequences *code*)))
+        (if changed-p
+            (setf *code* (optimize-jumps *code*))
+            (multiple-value-setq
+                (*code* changed-p)
+              (optimize-jumps *code*)))
+        (if changed-p
+            (setf *code* (delete-unreachable-code *code*))
+            (multiple-value-setq
+                (*code* changed-p)
+              (delete-unreachable-code *code*)))
+        (unless changed-p
+          (return))))
+    (unless (vectorp *code*)
+      (setf *code* (coerce *code* 'vector)))
+    (when *compiler-debug*
+      (sys::%format t "----- after optimization -----~%")
+      (print-code *code*)))
+  t)
+
+
+
+
 (defun code-bytes (code)
   (let ((length 0)
         labels ;; alist



From ehuelsmann at common-lisp.net  Sun Aug  8 10:06:38 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 08 Aug 2010 06:06:38 -0400
Subject: [armedbear-cvs] r12876 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Oi2m6-0004UA-3K@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug  8 06:06:35 2010
New Revision: 12876

Log:
Move FINALIZE-CODE to jvm-instructions.lisp and make it
really finalize all code.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Aug  8 06:06:35 2010
@@ -914,9 +914,6 @@
   (check-number-of-args form n t))
 
 
-(defun finalize-code ()
-  (setf *code* (nreverse (coerce *code* 'vector))))
-
 
 
 
@@ -1186,8 +1183,11 @@
            (aver nil)))
     (setf *code* (append *static-code* *code*))
     (emit 'return)
-    (finalize-code)
-    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
+    (setf *code*
+          (finalize-code *code* (nconc (mapcar #'handler-from *handlers*)
+                                       (mapcar #'handler-to *handlers*)
+                                       (mapcar #'handler-code *handlers*)) nil))
+
     (setf (method-max-stack constructor)
           (analyze-stack *code* (mapcar #'handler-code *handlers*)))
     (setf (method-code constructor) (code-bytes *code*))
@@ -7485,10 +7485,11 @@
 
 
     ;;;  Move here
-    (finalize-code)
-    (optimize-code)
+    (setf *code* (finalize-code *code*
+                                (nconc (mapcar #'handler-from *handlers*)
+                                       (mapcar #'handler-to *handlers*)
+                                       (mapcar #'handler-code *handlers*)) t))
 
-    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
     (setf (method-max-stack execute-method)
           (analyze-stack *code* (mapcar #'handler-code *handlers*)))
     (setf (method-code execute-method) (code-bytes *code*))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Sun Aug  8 06:06:35 2010
@@ -819,7 +819,7 @@
             changed)))
 
 
-(declaim (ftype (function (t) hash-table) hash-labels))
+(declaim (ftype (function (t) label-target-instructions) hash-labels))
 (defun label-target-instructions (code)
   (let ((ht (make-hash-table :test 'eq))
         (code (coerce code 'vector))
@@ -908,46 +908,42 @@
 
 (defvar *enable-optimization* t)
 
-(defknown optimize-code () t)
-(defun optimize-code ()
+(defknown optimize-code (t t) t)
+(defun optimize-code (code handler-labels)
   (unless *enable-optimization*
     (format t "optimizations are disabled~%"))
   (when *enable-optimization*
     (when *compiler-debug*
       (format t "----- before optimization -----~%")
-      (print-code *code*))
+      (print-code code))
     (loop
-      (let ((changed-p nil))
-        (multiple-value-setq
-            (*code* changed-p)
-          (delete-unused-labels *code*
-                                (nconc
-                                 (mapcar #'handler-from *handlers*)
-                                 (mapcar #'handler-to *handlers*)
-                                 (mapcar #'handler-code *handlers*))))
-        (if changed-p
-            (setf *code* (optimize-instruction-sequences *code*))
-            (multiple-value-setq
-                (*code* changed-p)
-              (optimize-instruction-sequences *code*)))
-        (if changed-p
-            (setf *code* (optimize-jumps *code*))
-            (multiple-value-setq
-                (*code* changed-p)
-              (optimize-jumps *code*)))
-        (if changed-p
-            (setf *code* (delete-unreachable-code *code*))
-            (multiple-value-setq
-                (*code* changed-p)
-              (delete-unreachable-code *code*)))
-        (unless changed-p
-          (return))))
-    (unless (vectorp *code*)
-      (setf *code* (coerce *code* 'vector)))
+       (let ((changed-p nil))
+         (multiple-value-setq
+             (code changed-p)
+           (delete-unused-labels code handler-labels))
+         (if changed-p
+             (setf code (optimize-instruction-sequences code))
+             (multiple-value-setq
+                 (code changed-p)
+               (optimize-instruction-sequences code)))
+         (if changed-p
+             (setf code (optimize-jumps code))
+             (multiple-value-setq
+                 (code changed-p)
+               (optimize-jumps code)))
+         (if changed-p
+             (setf code (delete-unreachable-code code))
+             (multiple-value-setq
+                 (code changed-p)
+               (delete-unreachable-code code)))
+         (unless changed-p
+           (return))))
+    (unless (vectorp code)
+      (setf code (coerce code 'vector)))
     (when *compiler-debug*
       (sys::%format t "----- after optimization -----~%")
-      (print-code *code*)))
-  t)
+      (print-code code)))
+  code)
 
 
 
@@ -997,6 +993,10 @@
               (incf index)))))
       (values bytes labels))))
 
-
+(defun finalize-code (code handler-labels optimize)
+  (setf code (coerce (nreverse code) 'vector))
+  (when optimize
+    (setf code (optimize-code code handler-labels)))
+  (resolve-instructions (expand-virtual-instructions code)))
 
 (provide '#:opcodes)



From ehuelsmann at common-lisp.net  Sun Aug  8 13:16:54 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 08 Aug 2010 09:16:54 -0400
Subject: [armedbear-cvs] r12877 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Oi5kE-0003rr-Dx@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug  8 09:16:53 2010
New Revision: 12877

Log:
Optimization functions optimize in tight loops, optimize for speed.
Also, remove iterator variable type declarations: our inferencer
knows their type.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Sun Aug  8 09:16:53 2010
@@ -733,7 +733,6 @@
   (let* ((code-length (length code)))
     (declare (type vector code))
     (dotimes (i code-length)
-      (declare (type (unsigned-byte 16) i))
       (let* ((instruction (aref code i))
              (opcode (instruction-opcode instruction)))
         (when (eql opcode 202) ; LABEL
@@ -762,7 +761,6 @@
     (let ((max-stack 0))
       (declare (type fixnum max-stack))
       (dotimes (i code-length)
-        (declare (type (unsigned-byte 16) i))
         (let* ((instruction (aref code i))
                (instruction-depth (instruction-depth instruction)))
           (when instruction-depth
@@ -771,12 +769,12 @@
 
 
 (defun delete-unused-labels (code handler-labels)
+  (declare (optimize speed))
   (let ((code (coerce code 'vector))
         (changed nil)
         (marker (gensym)))
     ;; Mark the labels that are actually branched to.
     (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
       (let ((instruction (aref code i)))
         (when (branch-p (instruction-opcode instruction))
           (let ((label (car (instruction-args instruction))))
@@ -786,7 +784,6 @@
       (set label marker))
     ;; Remove labels that are not used as branch targets.
     (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
       (let ((instruction (aref code i)))
         (when (= (instruction-opcode instruction) 202) ; LABEL
           (let ((label (car (instruction-args instruction))))
@@ -799,6 +796,7 @@
 
 (defun delete-unreachable-code (code)
   ;; Look for unreachable code after GOTO.
+  (declare (optimize speed))
   (let* ((code (coerce code 'vector))
          (changed nil)
          (after-goto/areturn nil))
@@ -825,7 +823,6 @@
         (code (coerce code 'vector))
         (pending-labels '()))
     (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
       (let ((instruction (aref code i)))
         (cond ((label-p instruction)
                (push (instruction-label instruction) pending-labels))
@@ -838,11 +835,11 @@
     ht))
 
 (defun optimize-jumps (code)
+  (declare (optimize speed))
   (let* ((code (coerce code 'vector))
          (ht (label-target-instructions code))
          (changed nil))
     (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
       (let* ((instruction (aref code i))
              (opcode (and instruction (instruction-opcode instruction))))
         (when (and opcode (branch-p opcode))
@@ -866,7 +863,6 @@
   (let* ((code (coerce code 'vector))
          (changed nil))
     (dotimes (i (1- (length code)))
-      (declare (type (unsigned-byte 16) i))
       (let* ((this-instruction (aref code i))
              (this-opcode (and this-instruction
                                (instruction-opcode this-instruction)))



From mevenson at common-lisp.net  Sun Aug  8 20:41:10 2010
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sun, 08 Aug 2010 16:41:10 -0400
Subject: [armedbear-cvs] r12878 - trunk/abcl/contrib/asdf-install
Message-ID: <E1OiCgA-0004Fo-E4@common-lisp.net>

Author: mevenson
Date: Sun Aug  8 16:41:08 2010
New Revision: 12878

Log:
Interactive restart to skip missing GPG signature.

A pretty awful hack using a DEFVAR form to communicate state from an
interactive restart makes it seem like I didn't get the memo about how
to use the Lisp condition system properly.  Mea culpa!  But it looks
like the code from how SBCL handles this would be a better place to go
then what we have currently.



Modified:
   trunk/abcl/contrib/asdf-install/installer.lisp

Modified: trunk/abcl/contrib/asdf-install/installer.lisp
==============================================================================
--- trunk/abcl/contrib/asdf-install/installer.lisp	(original)
+++ trunk/abcl/contrib/asdf-install/installer.lisp	Sun Aug  8 16:41:08 2010
@@ -151,20 +151,32 @@
 (defun download-link-for-signature (url)
   (concatenate 'string url ".asc"))
 
+;;; XXX unsightful hack
+(defvar *dont-check-signature* nil)
+
 (defun download-files-for-package (package-name-or-url)
+  (setf *dont-check-signature* nil)
   (multiple-value-bind (package-url package-file) 
       (download-url-to-temporary-file
        (download-link-for-package package-name-or-url))
     (if (verify-gpg-signatures-p package-name-or-url)
-	(multiple-value-bind (signature-url signature-file) 
-	    (download-url-to-temporary-file
-	     (download-link-for-signature package-url))
-	  (declare (ignore signature-url))
-	  (values package-file signature-file))
+        (restart-case
+            (multiple-value-bind (signature-url signature-file) 
+                (download-url-to-temporary-file
+                 (download-link-for-signature package-url))
+              (declare (ignore signature-url))
+              (values package-file signature-file))
+          (skip-gpg-check () 
+            :report "Don't check GPG signature for this package"
+            (progn
+              (setf *dont-check-signature* t)
+              (values package-file nil))))
 	(values package-file nil))))
   
 (defun verify-gpg-signature (file-name signature-name)
   (block verify
+    (when (and (null signature-name) *dont-check-signature*)
+      (return-from verify t))
     (loop
       (restart-case
 	  (let ((tags (gpg-results file-name signature-name)))



From ehuelsmann at common-lisp.net  Sun Aug  8 21:24:04 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 08 Aug 2010 17:24:04 -0400
Subject: [armedbear-cvs] r12879 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OiDLg-0006sT-Il@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug  8 17:24:03 2010
New Revision: 12879

Log:
Add 'dual mode' to DECLARE-FIELD.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Aug  8 17:24:03 2010
@@ -1275,14 +1275,19 @@
 (defconst +field-access-default+   #x00) ;; package accessible, used for LABELS
 
 (defknown declare-field (t t t) t)
-(defun declare-field (name descriptor access-flags)
-  (let ((field (make-field name (internal-field-ref descriptor))))
-    ;; final static <access-flags>
-    (setf (field-access-flags field)
-          (logior +field-flag-final+ +field-flag-static+ access-flags))
-    (setf (field-name-index field) (pool-name (field-name field)))
-    (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
-    (push field *fields*)))
+(defun declare-field (name descriptor)
+  (if *current-code-attribute*
+      (let ((field (!make-field name descriptor '(:final :static :private))))
+        (class-add-field *class-file* field))
+      (let ((field (make-field name (internal-field-ref descriptor))))
+        ;; final static <access-flags>
+        (setf (field-access-flags field)
+              (logior +field-flag-final+ +field-flag-static+
+                      +field-access-private+))
+        (setf (field-name-index field) (pool-name (field-name field)))
+        (setf (field-descriptor-index field)
+              (pool-name (field-descriptor field)))
+        (push field *fields*))))
 
 (defknown sanitize (symbol) string)
 (defun sanitize (symbol)
@@ -1467,7 +1472,7 @@
 
     ;; We need to set up the serialized value
     (let ((field-name (symbol-name (gensym prefix))))
-      (declare-field field-name field-type +field-access-private+)
+      (declare-field field-name field-type)
       (push (cons object field-name) *externalized-objects*)
 
       (cond
@@ -1504,7 +1509,7 @@
    (let ((s (sanitize symbol)))
      (when s
        (setf f (concatenate 'string f "_" s))))
-   (declare-field f +lisp-object+ +field-access-private+)
+   (declare-field f +lisp-object+)
    (multiple-value-bind
          (name class)
        (lookup-known-symbol symbol)
@@ -1557,7 +1562,7 @@
                        (local-function-class-file local-function)))
           (*code* *static-code*))
      ;; fixme *declare-inline*
-     (declare-field g +lisp-object+ +field-access-private+)
+     (declare-field g +lisp-object+)
      (emit-new class-name)
      (emit 'dup)
      (emit-invokespecial-init class-name '())
@@ -1582,7 +1587,7 @@
            (*code* (if *declare-inline* *code* *static-code*)))
       ;; strings may contain evaluated bits which may depend on
       ;; previous statements
-      (declare-field g +lisp-object+ +field-access-private+)
+      (declare-field g +lisp-object+)
       (emit 'ldc (pool-string s))
       (emit-invokestatic +lisp+ "readObjectFromString"
                          (list +java-string+) +lisp-object+)
@@ -1602,7 +1607,7 @@
       ;; The readObjectFromString call may require evaluation of
       ;; lisp code in the string (think #.() syntax), of which the outcome
       ;; may depend on something which was declared inline
-      (declare-field g +lisp-object+ +field-access-private+)
+      (declare-field g +lisp-object+)
       (emit 'ldc (pool-string s))
       (emit-invokestatic +lisp+ "readObjectFromString"
                          (list +java-string+) +lisp-object+)
@@ -1626,7 +1631,7 @@
     ;; fixme *declare-inline*?
     (remember g obj)
     (let* ((*code* *static-code*))
-      (declare-field g +lisp-object+ +field-access-private+)
+      (declare-field g +lisp-object+)
       (emit 'ldc (pool-string g))
       (emit-invokestatic +lisp+ "recall"
                          (list +java-string+) +lisp-object+)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Sun Aug  8 17:24:03 2010
@@ -82,6 +82,7 @@
 (defvar *pool-entries* nil)
 (defvar *fields* ())
 (defvar *static-code* ())
+(defvar *class-file* nil)
 
 (defvar *externalized-objects* nil)
 (defvar *declared-functions* nil)



From ehuelsmann at common-lisp.net  Mon Aug  9 08:49:01 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 09 Aug 2010 04:49:01 -0400
Subject: [armedbear-cvs] r12880 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OiO2X-0006vU-QL@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  9 04:48:58 2010
New Revision: 12880

Log:
Fix insertion of floats/doubles in the constant pool.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Mon Aug  9 04:48:58 2010
@@ -449,7 +449,8 @@
   "Returns the index of the constant-pool item denoting the float."
   (let ((entry (gethash (cons 4 float) (pool-entries pool))))
     (unless entry
-      (setf entry (make-constant-float (incf (pool-index pool)) float)
+      (setf entry (make-constant-float (incf (pool-index pool))
+                                       (sys::%float-bits float))
             (gethash (cons 4 float) (pool-entries pool)) entry)
       (push entry (pool-entries-list pool)))
     (constant-index entry)))
@@ -468,7 +469,8 @@
   "Returns the index of the constant-pool item denoting the double."
   (let ((entry (gethash (cons 6 double) (pool-entries pool))))
     (unless entry
-      (setf entry (make-constant-double (incf (pool-index pool)) double)
+      (setf entry (make-constant-double (incf (pool-index pool))
+                                        (sys::%float-bits double))
             (gethash (cons 6 double) (pool-entries pool)) entry)
       (push entry (pool-entries-list pool))
       (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots



From ehuelsmann at common-lisp.net  Mon Aug  9 11:31:54 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 09 Aug 2010 07:31:54 -0400
Subject: [armedbear-cvs] r12881 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OiQa9-0001VS-Vv@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  9 07:31:52 2010
New Revision: 12881

Log:
Switch pass2 to the pool routines from jvm-class-file.lisp.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  9 07:31:52 2010
@@ -45,130 +45,39 @@
   (require "JAVA"))
 
 
-(defun dump-pool ()
-  (let ((pool (reverse *pool*))
-        entry type)
-    (dotimes (index (1- *pool-count*))
-      (setq entry (car pool))
-      (setq type (case (car entry)
-                   (7 'class)
-                   (9 'field)
-                   (10 'method)
-                   (11 'interface)
-                   (8 'string)
-                   (3 'integer)
-                   (4 'float)
-                   (5 'long)
-                   (6 'double)
-                   (12 'name-and-type)
-                   (1 'utf8)))
-      (format t "~D: ~A ~S~%" (1+ index) type entry)
-      (setq pool (cdr pool))))
-  t)
-
-(defknown pool-get (t) (integer 1 65535))
-(defun pool-get (entry)
-  (declare (optimize speed (safety 0)))
-  (let* ((ht *pool-entries*)
-         (index (gethash1 entry ht)))
-    (declare (type hash-table ht))
-    (unless index
-      (setf index *pool-count*)
-      (push entry *pool*)
-      (setf (gethash entry ht) index)
-      (setf *pool-count* (1+ index)))
-    index))
+(declaim (inline pool-name pool-string pool-name-and-type
+                 pool-class pool-field pool-method pool-int
+                 pool-float pool-long pool-double))
 
-(declaim (ftype (function (string) fixnum) pool-name))
-(declaim (inline pool-name))
 (defun pool-name (name)
-  (declare (optimize speed))
-  (pool-get (list 1 (length name) name)))
+  (pool-add-utf8 *pool* name))
 
-(declaim (ftype (function (string string) fixnum) pool-name-and-type))
-(declaim (inline pool-name-and-type))
 (defun pool-name-and-type (name type)
-  (declare (optimize speed))
-  (pool-get (list 12
-                  (pool-name name)
-                  (pool-name type))))
-
-;; Assumes CLASS-NAME is already in the correct form ("org/armedbear/lisp/Lisp"
-;; as opposed to "org.armedbear.lisp.Lisp").
-(declaim (ftype (function (string) fixnum) pool-class))
-(declaim (inline pool-class))
-(defun pool-class (class-name)
-  (declare (optimize speed))
-  (pool-get (list 7 (pool-name (class-name-internal class-name)))))
+  (pool-add-name/type *pool* name type))
 
-;; (tag class-index name-and-type-index)
-(declaim (ftype (function (string string string) fixnum) pool-field))
-(declaim (inline pool-field))
-(defun pool-field (class-name field-name type-name)
-  (declare (optimize speed))
-  (pool-get (list 9
-                  (pool-class class-name)
-                  (pool-name-and-type field-name
-                                      (internal-field-ref type-name)))))
-
-;; (tag class-index name-and-type-index)
-(declaim (ftype (function (string string string) fixnum) pool-method))
-(declaim (inline pool-method))
-(defun pool-method (class-name method-name type-name)
-  (declare (optimize speed))
-  (pool-get (list 10
-                  (pool-class class-name)
-                  (pool-name-and-type method-name type-name))))
+(defun pool-class (name)
+  (pool-add-class *pool* name))
 
-(declaim (ftype (function (string) fixnum) pool-string))
 (defun pool-string (string)
-  (declare (optimize speed))
-  (pool-get (list 8 (pool-name string))))
+  (pool-add-string *pool* string))
 
-(defknown pool-int (fixnum) (integer 1 65535))
-(defun pool-int (n)
-  (declare (optimize speed))
-  (pool-get (list 3 n)))
+(defun pool-field (class-name field-name type-name)
+  (pool-add-field-ref *pool* class-name field-name type-name))
 
-(defknown pool-float (single-float) (integer 1 65535))
-(defun pool-float (n)
-  (declare (optimize speed))
-  (pool-get (list 4 (%float-bits n))))
+(defun pool-method (class-name method-name type-name)
+  (pool-add-method-ref *pool* class-name method-name type-name))
 
-(defun pool-long/double (entry)
-  (let* ((ht *pool-entries*)
-         (index (gethash1 entry ht)))
-    (declare (type hash-table ht))
-    (unless index
-      (setf index *pool-count*)
-      (push entry *pool*)
-      (setf (gethash entry ht) index)
-      ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte
-      ;; constants take up two entries in the constant_pool table of the class
-      ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the
-      ;; item in the constant_pool table at index n, then the next usable item in
-      ;; the pool is located at index n+2. The constant_pool index n+1 must be
-      ;; valid but is considered unusable." So:
-      (setf *pool-count* (+ index 2)))
-    index))
+(defun pool-int (int)
+  (pool-add-int *pool* int))
 
-(defknown pool-long (integer) (integer 1 65535))
-(defun pool-long (n)
-  (declare (optimize speed))
-  (declare (type java-long n))
-  (let* ((entry (list 5
-                      (logand (ash n -32) #xffffffff)
-                      (logand n #xffffffff))))
-    (pool-long/double entry)))
+(defun pool-float (float)
+  (pool-add-float *pool* float))
 
-(defknown pool-double (double-float) (integer 1 65535))
-(defun pool-double (n)
-  (declare (optimize speed))
-  (let* ((n (%float-bits n))
-         (entry (list 6
-                      (logand (ash n -32) #xffffffff)
-                      (logand n #xffffffff))))
-    (pool-long/double entry)))
+(defun pool-long (long)
+  (pool-add-long *pool* long))
+
+(defun pool-double (double)
+  (pool-add-double *pool* double))
 
 (defknown u2 (fixnum) cons)
 (defun u2 (n)
@@ -332,12 +241,9 @@
 
 (declaim (ftype (function * t) emit-invokestatic))
 (defun emit-invokestatic (class-name method-name arg-types return-type)
-  (let* ((descriptor (apply #'descriptor return-type arg-types))
-         (stack-effect (apply #'descriptor-stack-effect return-type arg-types))
-         (index (if (null *current-code-attribute*)
-                    (pool-method class-name method-name descriptor)
-                    (pool-add-method-ref *pool* class-name
-                                         method-name (cons return-type arg-types))))
+  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
+         (index (pool-add-method-ref *pool* class-name
+                                     method-name (cons return-type arg-types)))
          (instruction (apply #'%emit 'invokestatic (u2 index))))
     (setf (instruction-stack instruction) stack-effect)))
 
@@ -356,12 +262,9 @@
 
 (defknown emit-invokevirtual (t t t t) t)
 (defun emit-invokevirtual (class-name method-name arg-types return-type)
-  (let* ((descriptor (apply #'descriptor return-type arg-types))
-         (stack-effect (apply #'descriptor-stack-effect return-type arg-types))
-         (index (if (null *current-code-attribute*)
-                    (pool-method class-name method-name descriptor)
-                    (pool-add-method-ref *pool* class-name
-                                         method-name (cons return-type arg-types))))
+  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
+         (index (pool-add-method-ref *pool* class-name
+                                     method-name (cons return-type arg-types)))
          (instruction (apply #'%emit 'invokevirtual (u2 index))))
     (declare (type (signed-byte 8) stack-effect))
     (let ((explain *explain*))
@@ -376,12 +279,9 @@
 
 (defknown emit-invokespecial-init (string list) t)
 (defun emit-invokespecial-init (class-name arg-types)
-  (let* ((descriptor (apply #'descriptor :void arg-types))
-         (stack-effect (apply #'descriptor-stack-effect :void arg-types))
-         (index (if (null *current-code-attribute*)
-                    (pool-method class-name "<init>" descriptor)
-                    (pool-add-method-ref *pool* class-name
-                                         "<init>" (cons nil arg-types))))
+  (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types))
+         (index (pool-add-method-ref *pool* class-name
+                                     "<init>" (cons nil arg-types)))
          (instruction (apply #'%emit 'invokespecial (u2 index))))
     (declare (type (signed-byte 8) stack-effect))
     (setf (instruction-stack instruction) (1- stack-effect))))
@@ -1276,8 +1176,9 @@
 
 (defknown declare-field (t t t) t)
 (defun declare-field (name descriptor)
-  (if *current-code-attribute*
-      (let ((field (!make-field name descriptor '(:final :static :private))))
+  (if nil ;; *current-code-attribute*
+      (let ((field (!make-field name descriptor
+                                :flags '(:final :static :private))))
         (class-add-field *class-file* field))
       (let ((field (make-field name (internal-field-ref descriptor))))
         ;; final static <access-flags>
@@ -7200,7 +7101,7 @@
     (write-u4 #xCAFEBABE stream)
     (write-u2 3 stream)
     (write-u2 45 stream)
-    (write-constant-pool stream)
+    (write-constants *pool* stream)
     ;; access flags
     (write-u2 #x21 stream)
     (write-u2 this-index stream)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Mon Aug  9 07:31:52 2010
@@ -137,19 +137,15 @@
 
 (defmacro with-class-file (class-file &body body)
   (let ((var (gensym)))
-    `(let* ((,var ,class-file)
-            (*pool*                 (abcl-class-file-pool ,var))
-            (*pool-count*           (abcl-class-file-pool-count ,var))
-            (*pool-entries*         (abcl-class-file-pool-entries ,var))
+    `(let* ((,var                   ,class-file)
+            (*class-file*           ,var)
+            (*pool*                 (abcl-class-file-constants ,var))
             (*fields*               (abcl-class-file-fields ,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-pool ,var)         *pool*
-             (abcl-class-file-pool-count ,var)   *pool-count*
-             (abcl-class-file-pool-entries ,var) *pool-entries*
-             (abcl-class-file-fields ,var)       *fields*
+       (setf (abcl-class-file-fields ,var)       *fields*
              (abcl-class-file-static-code ,var)  *static-code*
              (abcl-class-file-objects ,var)      *externalized-objects*
              (abcl-class-file-functions ,var)    *declared-functions*))))



From ehuelsmann at common-lisp.net  Mon Aug  9 12:23:21 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 09 Aug 2010 08:23:21 -0400
Subject: [armedbear-cvs] r12882 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OiRNx-0007dJ-R5@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  9 08:23:20 2010
New Revision: 12882

Log:
Move the u2, s1 and s2 helper functions to jvm.lisp.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  9 08:23:20 2010
@@ -79,36 +79,6 @@
 (defun pool-double (double)
   (pool-add-double *pool* double))
 
-(defknown u2 (fixnum) cons)
-(defun u2 (n)
-  (declare (optimize speed))
-  (declare (type (unsigned-byte 16) n))
-  (when (not (<= 0 n 65535))
-    (error "u2 argument ~A out of 65k range." n))
-  (list (logand (ash n -8) #xff)
-        (logand n #xff)))
-
-(defknown s1 (fixnum) fixnum)
-(defun s1 (n)
-  (declare (optimize speed))
-  (declare (type (signed-byte 8) n))
-  (when (not (<= -128 n 127))
-    (error "s2 argument ~A out of 16-bit signed range." n))
-  (if (< n 0)
-      (1+ (logxor (- n) #xFF))
-      n))
-
-
-(defknown s2 (fixnum) cons)
-(defun s2 (n)
-  (declare (optimize speed))
-  (declare (type (signed-byte 16) n))
-  (when (not (<= -32768 n 32767))
-    (error "s2 argument ~A out of 16-bit signed range." n))
-  (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
-          n)))
-
-
 (defun add-exception-handler (start end handler type)
   (if (null *current-code-attribute*)
       (push (make-handler :from start

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Mon Aug  9 08:23:20 2010
@@ -62,6 +62,40 @@
 (defmacro dformat (&rest ignored)
   (declare (ignore ignored)))
 
+(declaim (inline u2 s1 s2))
+
+(defknown u2 (fixnum) cons)
+(defun u2 (n)
+  (declare (optimize speed))
+  (declare (type (unsigned-byte 16) n))
+  (when (not (<= 0 n 65535))
+    (error "u2 argument ~A out of 65k range." n))
+  (list (logand (ash n -8) #xff)
+        (logand n #xff)))
+
+(defknown s1 (fixnum) fixnum)
+(defun s1 (n)
+  (declare (optimize speed))
+  (declare (type (signed-byte 8) n))
+  (when (not (<= -128 n 127))
+    (error "s2 argument ~A out of 16-bit signed range." n))
+  (if (< n 0)
+      (1+ (logxor (- n) #xFF))
+      n))
+
+
+(defknown s2 (fixnum) cons)
+(defun s2 (n)
+  (declare (optimize speed))
+  (declare (type (signed-byte 16) n))
+  (when (not (<= -32768 n 32767))
+    (error "s2 argument ~A out of 16-bit signed range." n))
+  (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
+          n)))
+
+
+
+
 
 (defmacro with-saved-compiler-policy (&body body)
   "Saves compiler policy variables, restoring them after evaluating `body'."



From ehuelsmann at common-lisp.net  Mon Aug  9 12:50:33 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 09 Aug 2010 08:50:33 -0400
Subject: [armedbear-cvs] r12883 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OiRoH-0001qJ-MI@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  9 08:50:32 2010
New Revision: 12883

Log:
Switch fields to the new generator.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  9 08:50:32 2010
@@ -1146,19 +1146,9 @@
 
 (defknown declare-field (t t t) t)
 (defun declare-field (name descriptor)
-  (if nil ;; *current-code-attribute*
-      (let ((field (!make-field name descriptor
-                                :flags '(:final :static :private))))
-        (class-add-field *class-file* field))
-      (let ((field (make-field name (internal-field-ref descriptor))))
-        ;; final static <access-flags>
-        (setf (field-access-flags field)
-              (logior +field-flag-final+ +field-flag-static+
-                      +field-access-private+))
-        (setf (field-name-index field) (pool-name (field-name field)))
-        (setf (field-descriptor-index field)
-              (pool-name (field-descriptor field)))
-        (push field *fields*))))
+  (let ((field (!make-field name descriptor
+                            :flags '(:final :static :private))))
+    (class-add-field *class-file* field)))
 
 (defknown sanitize (symbol) string)
 (defun sanitize (symbol)
@@ -7067,7 +7057,9 @@
     (when (and (boundp '*source-line-number*)
                (fixnump *source-line-number*))
       (pool-name "LineNumberTable")) ; Must be in pool!
-    
+    (dolist (field (class-file-fields class-file))
+      (finalize-field field class-file))
+
     (write-u4 #xCAFEBABE stream)
     (write-u2 3 stream)
     (write-u2 45 stream)
@@ -7079,10 +7071,10 @@
     ;; interfaces count
     (write-u2 0 stream)
     ;; fields count
-    (write-u2 (length *fields*) stream)
+    (write-u2 (length (class-file-fields class-file)) stream)
     ;; fields
-    (dolist (field *fields*)
-      (write-field field stream))
+    (dolist (field (class-file-fields class-file))
+      (!write-field field stream))
     ;; methods count
     (write-u2 (1+ (length (abcl-class-file-methods class-file))) stream)
     ;; methods



From ehuelsmann at common-lisp.net  Mon Aug  9 14:10:51 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 09 Aug 2010 10:10:51 -0400
Subject: [armedbear-cvs] r12884 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OiT3z-0007Xq-Ah@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  9 10:10:50 2010
New Revision: 12884

Log:
Clean up after migration of fields and the pool.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  9 10:10:50 2010
@@ -866,42 +866,6 @@
             (write-8-bits (aref octets i) stream)))
         (write-ascii string length stream))))
 
-(defknown write-constant-pool-entry (t t) t)
-(defun write-constant-pool-entry (entry stream)
-  (declare (optimize speed))
-  (declare (type stream stream))
-  (let ((tag (first entry)))
-    (declare (type (integer 1 12) tag))
-    (write-u1 tag stream)
-    (case tag
-      (1 ; UTF8
-       (write-utf8 (third entry) stream))
-      ((3 4) ; int
-       (write-u4 (second entry) stream))
-      ((5 6) ; long double
-       (write-u4 (second entry) stream)
-       (write-u4 (third entry) stream))
-      ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType
-       (write-u2 (second entry) stream)
-       (write-u2 (third entry) stream))
-      ((7 8) ; class string
-       (write-u2 (second entry) stream))
-      (t
-       (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))
-
-(defun write-constant-pool (stream)
-  (declare (optimize speed))
-  (write-u2 *pool-count* stream)
-  (dolist (entry (reverse *pool*))
-    (write-constant-pool-entry entry stream)))
-
-(defstruct (field (:constructor make-field (name descriptor)))
-  access-flags
-  name
-  descriptor
-  name-index
-  descriptor-index)
-
 (defstruct (java-method (:include method)
                         (:conc-name method-)
                         (:constructor %make-method))
@@ -1130,24 +1094,11 @@
   (write-u2 1 stream) ; attributes count
   (write-code-attr method stream))
 
-(defun write-field (field stream)
-  (declare (optimize speed))
-  (write-u2 (or (field-access-flags field) #x1) stream) ; access flags
-  (write-u2 (field-name-index field) stream)
-  (write-u2 (field-descriptor-index field) stream)
-  (write-u2 0 stream)) ; attributes count
-
-(defconst +field-flag-final+       #x10) ;; final field
-(defconst +field-flag-static+      #x08) ;; static field
-(defconst +field-access-protected+ #x04) ;; subclass accessible
-(defconst +field-access-private+   #x02) ;; class-only accessible
-(defconst +field-access-public+    #x01) ;; generally accessible
-(defconst +field-access-default+   #x00) ;; package accessible, used for LABELS
 
 (defknown declare-field (t t t) t)
 (defun declare-field (name descriptor)
-  (let ((field (!make-field name descriptor
-                            :flags '(:final :static :private))))
+  (let ((field (make-field name descriptor
+                           :flags '(:final :static :private))))
     (class-add-field *class-file* field)))
 
 (defknown sanitize (symbol) string)
@@ -7074,7 +7025,7 @@
     (write-u2 (length (class-file-fields class-file)) stream)
     ;; fields
     (dolist (field (class-file-fields class-file))
-      (!write-field field stream))
+      (write-field field stream))
     ;; methods count
     (write-u2 (1+ (length (abcl-class-file-methods class-file))) stream)
     ;; methods

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Mon Aug  9 10:10:50 2010
@@ -603,7 +603,7 @@
   ;; fields
   (write-u2 (length (class-file-fields class)) stream)
   (dolist (field (class-file-fields class))
-    (!write-field field stream))
+    (write-field field stream))
 
   ;; methods
   (write-u2 (length (class-file-methods class)) stream)
@@ -713,7 +713,7 @@
   descriptor
   attributes)
 
-(defun !make-field (name type &key (flags '(:public)))
+(defun make-field (name type &key (flags '(:public)))
   "Creates a field for addition to a class file."
   (%make-field :access-flags flags
                :name name
@@ -741,7 +741,7 @@
           (pool-add-utf8 pool (field-name field))))
   (finalize-attributes (field-attributes field) nil class))
 
-(defun !write-field (field stream)
+(defun write-field (field stream)
   "Writes classfile representation of `field' to `stream'."
   (write-u2 (field-access-flags field) stream)
   (write-u2 (field-name field) stream)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Mon Aug  9 10:10:50 2010
@@ -112,9 +112,6 @@
 (defvar *compiler-debug* nil)
 
 (defvar *pool* nil)
-(defvar *pool-count* 1)
-(defvar *pool-entries* nil)
-(defvar *fields* ())
 (defvar *static-code* ())
 (defvar *class-file* nil)
 
@@ -174,13 +171,11 @@
     `(let* ((,var                   ,class-file)
             (*class-file*           ,var)
             (*pool*                 (abcl-class-file-constants ,var))
-            (*fields*               (abcl-class-file-fields ,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-fields ,var)       *fields*
-             (abcl-class-file-static-code ,var)  *static-code*
+       (setf (abcl-class-file-static-code ,var)  *static-code*
              (abcl-class-file-objects ,var)      *externalized-objects*
              (abcl-class-file-functions ,var)    *declared-functions*))))
 



From ehuelsmann at common-lisp.net  Mon Aug  9 15:16:06 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Mon, 09 Aug 2010 11:16:06 -0400
Subject: [armedbear-cvs] r12885 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OiU58-0003SA-4p@common-lisp.net>

Author: ehuelsmann
Date: Mon Aug  9 11:16:05 2010
New Revision: 12885

Log:
Move byte-sequence writing routines to jvm-class-file.lisp.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Mon Aug  9 11:16:05 2010
@@ -786,86 +786,6 @@
 
 
 
-
-(declaim (inline write-u1))
-(defun write-u1 (n stream)
-  (declare (optimize speed))
-  (declare (type (unsigned-byte 8) n))
-  (declare (type stream stream))
-  (write-8-bits n stream))
-
-(defknown write-u2 (t t) t)
-(defun write-u2 (n stream)
-  (declare (optimize speed))
-  (declare (type (unsigned-byte 16) n))
-  (declare (type stream stream))
-  (write-8-bits (logand (ash n -8) #xFF) stream)
-  (write-8-bits (logand n #xFF) stream))
-
-(defknown write-u4 (integer stream) t)
-(defun write-u4 (n stream)
-  (declare (optimize speed))
-  (declare (type (unsigned-byte 32) n))
-  (write-u2 (logand (ash n -16) #xFFFF) stream)
-  (write-u2 (logand n #xFFFF) stream))
-
-(declaim (ftype (function (t t) t) write-s4))
-(defun write-s4 (n stream)
-  (declare (optimize speed))
-  (cond ((minusp n)
-         (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
-        (t
-         (write-u4 n stream))))
-
-(declaim (ftype (function (t t t) t) write-ascii))
-(defun write-ascii (string length stream)
-  (declare (type string string))
-  (declare (type (unsigned-byte 16) length))
-  (declare (type stream stream))
-  (write-u2 length stream)
-  (dotimes (i length)
-    (declare (type (unsigned-byte 16) i))
-    (write-8-bits (char-code (char string i)) stream)))
-
-(declaim (ftype (function (t t) t) write-utf8))
-(defun write-utf8 (string stream)
-  (declare (optimize speed))
-  (declare (type string string))
-  (declare (type stream stream))
-  (let ((length (length string))
-        (must-convert nil))
-    (declare (type fixnum length))
-    (dotimes (i length)
-      (declare (type fixnum i))
-      (unless (< 0 (char-code (char string i)) #x80)
-        (setf must-convert t)
-        (return)))
-    (if must-convert
-        (let ((octets (make-array (* length 2)
-                                  :element-type '(unsigned-byte 8)
-                                  :adjustable t
-                                  :fill-pointer 0)))
-          (declare (type (vector (unsigned-byte 8)) octets))
-          (dotimes (i length)
-            (declare (type fixnum i))
-            (let* ((c (char string i))
-                   (n (char-code c)))
-              (cond ((zerop n)
-                     (vector-push-extend #xC0 octets)
-                     (vector-push-extend #x80 octets))
-                    ((< 0 n #x80)
-                     (vector-push-extend n octets))
-                    (t
-                     (let ((char-octets (char-to-utf8 c)))
-                       (dotimes (j (length char-octets))
-                         (declare (type fixnum j))
-                         (vector-push-extend (svref char-octets j) octets)))))))
-          (write-u2 (length octets) stream)
-          (dotimes (i (length octets))
-            (declare (type fixnum i))
-            (write-8-bits (aref octets i) stream)))
-        (write-ascii string length stream))))
-
 (defstruct (java-method (:include method)
                         (:conc-name method-)
                         (:constructor %make-method))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Mon Aug  9 11:16:05 2010
@@ -579,6 +579,88 @@
   ;; top-level attributes (no parent attributes to refer to)
   (finalize-attributes (class-file-attributes class) nil class))
 
+
+(declaim (inline write-u1 write-u2 write-u4 write-s4))
+(defun write-u1 (n stream)
+  (declare (optimize speed))
+  (declare (type (unsigned-byte 8) n))
+  (declare (type stream stream))
+  (write-8-bits n stream))
+
+(defknown write-u2 (t t) t)
+(defun write-u2 (n stream)
+  (declare (optimize speed))
+  (declare (type (unsigned-byte 16) n))
+  (declare (type stream stream))
+  (write-8-bits (logand (ash n -8) #xFF) stream)
+  (write-8-bits (logand n #xFF) stream))
+
+(defknown write-u4 (integer stream) t)
+(defun write-u4 (n stream)
+  (declare (optimize speed))
+  (declare (type (unsigned-byte 32) n))
+  (write-u2 (logand (ash n -16) #xFFFF) stream)
+  (write-u2 (logand n #xFFFF) stream))
+
+(declaim (ftype (function (t t) t) write-s4))
+(defun write-s4 (n stream)
+  (declare (optimize speed))
+  (cond ((minusp n)
+         (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
+        (t
+         (write-u4 n stream))))
+
+(declaim (ftype (function (t t t) t) write-ascii))
+(defun write-ascii (string length stream)
+  (declare (type string string))
+  (declare (type (unsigned-byte 16) length))
+  (declare (type stream stream))
+  (write-u2 length stream)
+  (dotimes (i length)
+    (declare (type (unsigned-byte 16) i))
+    (write-8-bits (char-code (char string i)) stream)))
+
+
+(declaim (ftype (function (t t) t) write-utf8))
+(defun write-utf8 (string stream)
+  (declare (optimize speed))
+  (declare (type string string))
+  (declare (type stream stream))
+  (let ((length (length string))
+        (must-convert nil))
+    (declare (type fixnum length))
+    (dotimes (i length)
+      (declare (type fixnum i))
+      (unless (< 0 (char-code (char string i)) #x80)
+        (setf must-convert t)
+        (return)))
+    (if must-convert
+        (let ((octets (make-array (* length 2)
+                                  :element-type '(unsigned-byte 8)
+                                  :adjustable t
+                                  :fill-pointer 0)))
+          (declare (type (vector (unsigned-byte 8)) octets))
+          (dotimes (i length)
+            (declare (type fixnum i))
+            (let* ((c (char string i))
+                   (n (char-code c)))
+              (cond ((zerop n)
+                     (vector-push-extend #xC0 octets)
+                     (vector-push-extend #x80 octets))
+                    ((< 0 n #x80)
+                     (vector-push-extend n octets))
+                    (t
+                     (let ((char-octets (char-to-utf8 c)))
+                       (dotimes (j (length char-octets))
+                         (declare (type fixnum j))
+                         (vector-push-extend (svref char-octets j) octets)))))))
+          (write-u2 (length octets) stream)
+          (dotimes (i (length octets))
+            (declare (type fixnum i))
+            (write-8-bits (aref octets i) stream)))
+        (write-ascii string length stream))))
+
+
 (defun !write-class-file (class stream)
   "Serializes `class' to `stream', after it has been finalized."
 



From ehuelsmann at common-lisp.net  Wed Aug 11 22:09:57 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Wed, 11 Aug 2010 18:09:57 -0400
Subject: [armedbear-cvs] r12886 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OjJUj-0004wG-B0@common-lisp.net>

Author: ehuelsmann
Date: Wed Aug 11 18:09:55 2010
New Revision: 12886

Log:
Resolve naming conflict between JAVA-METHOD and METHOD;
also adjust a call to FINALIZE-CODE to the new
number of arguments it takes.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Wed Aug 11 18:09:55 2010
@@ -533,14 +533,14 @@
 (defun class-methods-by-name (class name)
   "Returns all methods which have `name'."
   (remove name (class-file-methods class)
-          :test-not #'string= :key #'method-name))
+          :test-not #'string= :key #'!method-name))
 
 (defun class-method (class name return &rest args)
   "Return the method which is (uniquely) identified by its name AND descriptor."
   (let ((return-and-args (cons return args)))
     (find-if #'(lambda (c)
-                 (and (string= (method-name c) name)
-                      (equal (method-descriptor c) return-and-args)))
+                 (and (string= (!method-name c) name)
+                      (equal (!method-descriptor c) return-and-args)))
              (class-file-methods class))))
 
 (defun class-add-attribute (class attribute)
@@ -831,7 +831,8 @@
   (write-attributes (field-attributes field) stream))
 
 
-(defstruct (method (:constructor %!make-method))
+(defstruct (method (:constructor %!make-method)
+                   (:conc-name !method-))
   "Holds information on the properties of methods in the class(-file)."
   access-flags
   name
@@ -862,7 +863,7 @@
 (defun method-add-attribute (method attribute)
   "Add `attribute' to the list of attributes of `method',
 returning `attribute'."
-  (push attribute (method-attributes method))
+  (push attribute (!method-attributes method))
   attribute)
 
 (defun method-add-code (method)
@@ -870,8 +871,8 @@
 returning the created attribute."
   (method-add-attribute
    method
-   (make-code-attribute (+ (length (cdr (method-descriptor method)))
-                           (if (member :static (method-access-flags method))
+   (make-code-attribute (+ (length (cdr (!method-descriptor method)))
+                           (if (member :static (!method-access-flags method))
                                0 1))))) ;; 1 == implicit 'this'
 
 (defun method-ensure-code (method)
@@ -884,29 +885,29 @@
 
 (defun method-attribute (method name)
   "Returns the first attribute of `method' with `name'."
-  (find name (method-attributes method)
+  (find name (!method-attributes method)
         :test #'string= :key #'attribute-name))
 
 
 (defun finalize-method (method class)
   "Prepares `method' for serialization."
   (let ((pool (class-file-constants class)))
-    (setf (method-access-flags method)
-          (map-flags (method-access-flags method))
-          (method-descriptor method)
-          (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
-          (method-name method)
-          (pool-add-utf8 pool (map-method-name (method-name method)))))
-  (finalize-attributes (method-attributes method) nil class))
+    (setf (!method-access-flags method)
+          (map-flags (!method-access-flags method))
+          (!method-descriptor method)
+          (pool-add-utf8 pool (apply #'descriptor (!method-descriptor method)))
+          (!method-name method)
+          (pool-add-utf8 pool (map-method-name (!method-name method)))))
+  (finalize-attributes (!method-attributes method) nil class))
 
 
 (defun !write-method (method stream)
   "Write class file representation of `method' to `stream'."
-  (write-u2 (method-access-flags method) stream)
-  (write-u2 (method-name method) stream)
-  (sys::%format t "method-name: ~a~%" (method-name method))
-  (write-u2 (method-descriptor method) stream)
-  (write-attributes (method-attributes method) stream))
+  (write-u2 (!method-access-flags method) stream)
+  (write-u2 (!method-name method) stream)
+  ;;(sys::%format t "method-name: ~a~%" (!method-name method))
+  (write-u2 (!method-descriptor method) stream)
+  (write-attributes (!method-attributes method) stream))
 
 (defstruct attribute
   "Parent attribute structure to be included into other attributes, mainly
@@ -983,8 +984,15 @@
 (defun !finalize-code (code parent class)
   "Prepares the `code' attribute for serialization, within method `parent'."
   (declare (ignore parent))
-  (let ((c (resolve-instructions (coerce (reverse (code-code code)) 'vector))))
-    (setf (code-max-stack code) (analyze-stack c))
+  (let* ((handlers (code-exception-handlers code))
+         (c (finalize-code
+                     (code-code code)
+                     (nconc (mapcar #'exception-start-pc handlers)
+                            (mapcar #'exception-end-pc handlers)
+                            (mapcar #'exception-handler-pc handlers))
+                     t)))
+    (setf (code-max-stack code)
+          (analyze-stack c (mapcar #'exception-handler-pc handlers)))
     (multiple-value-bind
           (c labels)
         (code-bytes c)
@@ -1008,23 +1016,23 @@
 
 (defun !write-code (code stream)
   "Writes the attribute `code' to `stream'."
-  (sys::%format t "max-stack: ~a~%" (code-max-stack code))
+  ;;(sys::%format t "max-stack: ~a~%" (code-max-stack code))
   (write-u2 (code-max-stack code) stream)
-  (sys::%format t "max-locals: ~a~%" (code-max-locals code))
+  ;;(sys::%format t "max-locals: ~a~%" (code-max-locals code))
   (write-u2 (code-max-locals code) stream)
   (let ((code-array (code-code code)))
-    (sys::%format t "length: ~a~%" (length code-array))
+    ;;(sys::%format t "length: ~a~%" (length code-array))
     (write-u4 (length code-array) stream)
     (dotimes (i (length code-array))
       (write-u1 (svref code-array i) stream)))
 
   (write-u2 (length (code-exception-handlers code)) stream)
   (dolist (exception (reverse (code-exception-handlers code)))
-    (sys::%format t "start-pc: ~a~%" (exception-start-pc exception))
+    ;;(sys::%format t "start-pc: ~a~%" (exception-start-pc exception))
     (write-u2 (exception-start-pc exception) stream)
-    (sys::%format t "end-pc: ~a~%" (exception-end-pc exception))
+    ;;(sys::%format t "end-pc: ~a~%" (exception-end-pc exception))
     (write-u2 (exception-end-pc exception) stream)
-    (sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception))
+    ;;(sys::%format t "handler-pc: ~a~%" (exception-handler-pc exception))
     (write-u2 (exception-handler-pc exception) stream)
     (write-u2 (exception-catch-type exception) stream))
 



From ehuelsmann at common-lisp.net  Wed Aug 11 22:11:50 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Wed, 11 Aug 2010 18:11:50 -0400
Subject: [armedbear-cvs] r12887 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OjJWX-00050H-UI@common-lisp.net>

Author: ehuelsmann
Date: Wed Aug 11 18:11:49 2010
New Revision: 12887

Log:
Switch MAKE-CONSTRUCTOR over to the new class writer.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Wed Aug 11 18:11:49 2010
@@ -831,8 +831,9 @@
 (defun make-constructor (super lambda-name args)
   (let* ((*compiler-debug* nil)
          ;; We don't normally need to see debugging output for constructors.
-         (constructor (make-method :name "<init>"
-                                   :descriptor "()V"))
+         (method (!make-method :constructor :void nil
+                               :flags '(:public)))
+         (code (method-add-code method))
          req-params-register
          opt-params-register
          key-params-register
@@ -840,8 +841,8 @@
          keys-p
          more-keys-p
          (*code* ())
-         (*handlers* nil))
-    (setf (method-max-locals constructor) 1)
+         (*current-code-attribute* code))
+    (setf (code-max-locals code) 3)
     (unless (eq super +lisp-primitive+)
       (multiple-value-bind
             (req opt key key-p rest
@@ -856,8 +857,8 @@
                  `(progn
                     (emit-push-constant-int (length ,params))
                     (emit-anewarray +lisp-closure-parameter+)
-                    (astore (setf ,register (method-max-locals constructor)))
-                    (incf (method-max-locals constructor))
+                    (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)))
@@ -937,16 +938,8 @@
            (aver nil)))
     (setf *code* (append *static-code* *code*))
     (emit 'return)
-    (setf *code*
-          (finalize-code *code* (nconc (mapcar #'handler-from *handlers*)
-                                       (mapcar #'handler-to *handlers*)
-                                       (mapcar #'handler-code *handlers*)) nil))
-
-    (setf (method-max-stack constructor)
-          (analyze-stack *code* (mapcar #'handler-code *handlers*)))
-    (setf (method-code constructor) (code-bytes *code*))
-    (setf (method-handlers constructor) (nreverse *handlers*))
-    constructor))
+    (setf (code-code code) *code*)
+    method))
 
 (defun write-exception-table (method stream)
   (let ((handlers (method-handlers method)))
@@ -6930,6 +6923,7 @@
       (pool-name "LineNumberTable")) ; Must be in pool!
     (dolist (field (class-file-fields class-file))
       (finalize-field field class-file))
+    (finalize-method constructor class-file)
 
     (write-u4 #xCAFEBABE stream)
     (write-u2 3 stream)
@@ -6951,7 +6945,7 @@
     ;; methods
     (dolist (method (abcl-class-file-methods class-file))
       (write-method method stream))
-    (write-method constructor stream)
+    (!write-method constructor stream)
     ;; attributes count
     (cond (*file-compilation*
 	   ;; attributes count



From mevenson at common-lisp.net  Thu Aug 12 08:50:16 2010
From: mevenson at common-lisp.net (Mark Evenson)
Date: Thu, 12 Aug 2010 04:50:16 -0400
Subject: [armedbear-cvs] r12888 - trunk/abcl/test/lisp/ansi
Message-ID: <E1OjTUO-0008VF-80@common-lisp.net>

Author: mevenson
Date: Thu Aug 12 04:50:13 2010
New Revision: 12888

Log:
Fix typo.



Modified:
   trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp

Modified: trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp
==============================================================================
--- trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp	(original)
+++ trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp	Thu Aug 12 04:50:13 2010
@@ -76,7 +76,7 @@
 (defvar *default-database-file* 
   (if (find :asdf2 *features*)
       (asdf:system-relative-pathname :ansi-compiled "test/lisp/ansi/ansi-test-failures")
-      (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*)))
+      (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*))))
 
 (defun parse (&optional (file *default-database-file*))
   (format t "Parsing test report database from ~A~%" *default-database-file*)
@@ -151,7 +151,4 @@
           (format t "~A[~A] --> ~A[~A] additional failures:~%~A~%" 
                   version-2 id2 version-1 id1 diff-2->1))))))
             
-  
-
-         
         
\ No newline at end of file



From ehuelsmann at common-lisp.net  Thu Aug 12 20:08:52 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 12 Aug 2010 16:08:52 -0400
Subject: [armedbear-cvs] r12889 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Oje56-0004Tl-3w@common-lisp.net>

Author: ehuelsmann
Date: Thu Aug 12 16:08:50 2010
New Revision: 12889

Log:
Simplify ANALYZE-ARGS.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Thu Aug 12 16:08:50 2010
@@ -6869,34 +6869,20 @@
     (dformat t "analyze-args args = ~S~%" args)
     (aver (not (memq '&AUX args)))
 
-    (when *child-p*
-      (when (or (memq '&KEY args)
-                (memq '&OPTIONAL args)
-                (memq '&REST args))
-        (setf *using-arg-array* t)
-        (setf *hairy-arglist-p* t)
-        (return-from analyze-args
-          (descriptor +lisp-object+ +lisp-object-array+)))
-      (return-from analyze-args
-        (cond ((<= arg-count call-registers-limit)
-               (apply #'descriptor +lisp-object+
-                      (lisp-object-arg-types arg-count)))
-              (t (setf *using-arg-array* t)
-                 (setf (compiland-arity compiland) arg-count)
-                 (descriptor +lisp-object+ +lisp-object-array+)))))
     (when (or (memq '&KEY args)
               (memq '&OPTIONAL args)
               (memq '&REST args))
-      (setf *using-arg-array* t)
-      (setf *hairy-arglist-p* t)
-      (return-from analyze-args (descriptor +lisp-object+ +lisp-object-array+)))
+      (setf *using-arg-array* t
+            *hairy-arglist-p* t)
+      (return-from analyze-args
+          (descriptor +lisp-object+ +lisp-object-array+)))
+
     (cond ((<= arg-count call-registers-limit)
            (apply #'descriptor +lisp-object+
-                      (lisp-object-arg-types (length args))))
-          (t
-           (setf *using-arg-array* t)
-           (setf (compiland-arity compiland) arg-count)
-           (descriptor +lisp-object+ +lisp-object-array+)))))
+                  (lisp-object-arg-types arg-count)))
+          (t (setf *using-arg-array* t)
+             (setf (compiland-arity compiland) arg-count)
+             (descriptor +lisp-object+ +lisp-object-array+)))))
 
 (defmacro with-open-class-file ((var class-file) &body body)
   `(with-open-file (,var (abcl-class-file-pathname ,class-file)



From ehuelsmann at common-lisp.net  Thu Aug 12 21:10:25 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 12 Aug 2010 17:10:25 -0400
Subject: [armedbear-cvs] r12890 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ojf2f-0008Mn-IH@common-lisp.net>

Author: ehuelsmann
Date: Thu Aug 12 17:10:24 2010
New Revision: 12890

Log:
Clean up after old pool concept removal.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Thu Aug 12 17:10:24 2010
@@ -123,9 +123,6 @@
   pathname ; pathname of output file
   lambda-name
   lambda-list ; as advertised
-  pool
-  (pool-count 1)
-  (pool-entries (make-hash-table :test #'equal))
   static-code
   objects ;; an alist of externalized objects and their field names
   (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions



From ehuelsmann at common-lisp.net  Thu Aug 12 21:43:09 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Thu, 12 Aug 2010 17:43:09 -0400
Subject: [armedbear-cvs] r12891 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OjfYK-00027y-V4@common-lisp.net>

Author: ehuelsmann
Date: Thu Aug 12 17:43:08 2010
New Revision: 12891

Log:
Remove debugging artifact.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Thu Aug 12 17:43:08 2010
@@ -842,7 +842,7 @@
          more-keys-p
          (*code* ())
          (*current-code-attribute* code))
-    (setf (code-max-locals code) 3)
+    (setf (code-max-locals code) 1)
     (unless (eq super +lisp-primitive+)
       (multiple-value-bind
             (req opt key key-p rest



From ehuelsmann at common-lisp.net  Fri Aug 13 19:06:41 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 13 Aug 2010 15:06:41 -0400
Subject: [armedbear-cvs] r12892 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OjzaS-0002eS-WA@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug 13 15:06:37 2010
New Revision: 12892

Log:
Prepare ANALYZE-ARGS for the new class file generator.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 13 15:06:37 2010
@@ -6862,7 +6862,7 @@
 
 
 
-;; Returns descriptor.
+;; Returns a list with the types of the arguments
 (defun analyze-args (compiland)
   (let* ((args (cadr (compiland-p1-result compiland)))
          (arg-count (length args)))
@@ -6874,15 +6874,13 @@
               (memq '&REST args))
       (setf *using-arg-array* t
             *hairy-arglist-p* t)
-      (return-from analyze-args
-          (descriptor +lisp-object+ +lisp-object-array+)))
+      (return-from analyze-args (list +lisp-object-array+)))
 
     (cond ((<= arg-count call-registers-limit)
-           (apply #'descriptor +lisp-object+
-                  (lisp-object-arg-types arg-count)))
+           (lisp-object-arg-types arg-count))
           (t (setf *using-arg-array* t)
              (setf (compiland-arity compiland) arg-count)
-             (descriptor +lisp-object+ +lisp-object-array+)))))
+             +lisp-object-array+))))
 
 (defmacro with-open-class-file ((var class-file) &body body)
   `(with-open-file (,var (abcl-class-file-pathname ,class-file)
@@ -7005,9 +7003,11 @@
 
          (*child-p* (not (null (compiland-parent compiland))))
 
-         (descriptor (analyze-args compiland))
+         (arg-types (analyze-args compiland))
          (execute-method (make-method :name "execute"
-                                      :descriptor descriptor))
+                                      :descriptor (apply #'descriptor
+                                                         +lisp-object+
+                                                         arg-types)))
          (*code* ())
          (*register* 1) ;; register 0: "this" pointer
          (*registers-allocated* 1)



From ehuelsmann at common-lisp.net  Fri Aug 13 19:19:07 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 13 Aug 2010 15:19:07 -0400
Subject: [armedbear-cvs] r12893 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OjzmV-0003Y9-DS@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug 13 15:19:06 2010
New Revision: 12893

Log:
Now that we migrated to the new pool, clean up some code
explicitly testing for that.
Also, fix the last commit (ANALYZE-ARGS).

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 13 15:19:06 2010
@@ -291,31 +291,23 @@
 (declaim (inline emit-getstatic emit-putstatic))
 (defknown emit-getstatic (t t t) t)
 (defun emit-getstatic (class-name field-name type)
-  (let ((index (if (null *current-code-attribute*)
-                   (pool-field class-name field-name type)
-                   (pool-add-field-ref *pool* class-name field-name type))))
+  (let ((index (pool-add-field-ref *pool* class-name field-name type)))
     (apply #'%emit 'getstatic (u2 index))))
 
 (defknown emit-putstatic (t t t) t)
 (defun emit-putstatic (class-name field-name type)
-  (let ((index (if (null *current-code-attribute*)
-                   (pool-field class-name field-name type)
-                   (pool-add-field-ref *pool* class-name field-name type))))
+  (let ((index (pool-add-field-ref *pool* class-name field-name type)))
     (apply #'%emit 'putstatic (u2 index))))
 
 (declaim (inline emit-getfield emit-putfield))
 (defknown emit-getfield (t t t) t)
 (defun emit-getfield (class-name field-name type)
-  (let* ((index (if (null *current-code-attribute*)
-                    (pool-field class-name field-name type)
-                    (pool-add-field-ref *pool* class-name field-name type))))
+  (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
     (apply #'%emit 'getfield (u2 index))))
 
 (defknown emit-putfield (t t t) t)
 (defun emit-putfield (class-name field-name type)
-  (let* ((index (if (null *current-code-attribute*)
-                    (pool-field class-name field-name type)
-                    (pool-add-field-ref *pool* class-name field-name type))))
+  (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
     (apply #'%emit 'putfield (u2 index))))
 
 
@@ -6880,7 +6872,7 @@
            (lisp-object-arg-types arg-count))
           (t (setf *using-arg-array* t)
              (setf (compiland-arity compiland) arg-count)
-             +lisp-object-array+))))
+             (list +lisp-object-array+)))))
 
 (defmacro with-open-class-file ((var class-file) &body body)
   `(with-open-file (,var (abcl-class-file-pathname ,class-file)



From ehuelsmann at common-lisp.net  Fri Aug 13 20:25:21 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 13 Aug 2010 16:25:21 -0400
Subject: [armedbear-cvs] r12894 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ok0ob-0000An-81@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug 13 16:25:20 2010
New Revision: 12894

Log:
Generate the execute() methods through the new generator.

Changed:
 * CLEAR-VALUES instruction now takes the thread-register
   as its argument, to disconnect code-finalization from
   the scope of the *THREAD* binding.

Clean up:
 * JAVA-METHOD (structure)
 * HANDLER (structure)
 * WRITE-METHOD (function)
 * MAKE-METHOD (function)
 * WRITE-CODE-ATTR (function)
 * WRITE-EXCEPTION-TABLE (function)
 * remove code-finalization from P2-COMPILAND

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 13 16:25:20 2010
@@ -80,16 +80,8 @@
   (pool-add-double *pool* double))
 
 (defun add-exception-handler (start end handler type)
-  (if (null *current-code-attribute*)
-      (push (make-handler :from start
-                          :to end
-                          :code handler
-                          :catch-type (if (null type)
-                                          0
-                                          (pool-class type)))
-            *handlers*)
-      (code-add-exception-handler *current-code-attribute*
-                                  start end handler type)))
+  (code-add-exception-handler *current-code-attribute*
+                              start end handler type))
 
 
 
@@ -635,7 +627,7 @@
 (defun emit-clear-values ()
   (declare (optimize speed (safety 0)))
   (ensure-thread-var-initialized)
-  (emit 'clear-values))
+  (emit 'clear-values *thread*))
 
 (defknown maybe-emit-clear-values (&rest t) t)
 (defun maybe-emit-clear-values (&rest forms)
@@ -643,7 +635,7 @@
   (dolist (form forms)
     (unless (single-valued-p form)
       (ensure-thread-var-initialized)
-      (emit 'clear-values)
+      (emit 'clear-values *thread*)
       (return))))
 
 (defun compile-forms-and-maybe-emit-clear-values (&rest forms-and-compile-args)
@@ -777,25 +769,6 @@
 
 
 
-
-(defstruct (java-method (:include method)
-                        (:conc-name method-)
-                        (:constructor %make-method))
-  name-index
-  descriptor-index
-  max-stack
-  max-locals
-  code
-  handlers)
-
-(defun make-method (&rest args &key descriptor name
-                                    descriptor-index name-index
-                               &allow-other-keys)
-  (apply #'%make-method
-         (list* :descriptor-index (or descriptor-index (pool-name descriptor))
-                :name-index (or name-index (pool-name name))
-                args)))
-
 (defun emit-constructor-lambda-name (lambda-name)
   (cond ((and lambda-name (symbolp lambda-name) (symbol-package (truly-the symbol lambda-name)))
          (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name))))
@@ -933,14 +906,6 @@
     (setf (code-code code) *code*)
     method))
 
-(defun write-exception-table (method stream)
-  (let ((handlers (method-handlers method)))
-    (write-u2 (length handlers) stream) ; number of entries
-    (dolist (handler handlers)
-      (write-u2 (symbol-value (handler-from handler)) stream)
-      (write-u2 (symbol-value (handler-to handler)) stream)
-      (write-u2 (symbol-value (handler-code handler)) stream)
-      (write-u2 (handler-catch-type handler) stream))))
 
 (defun write-source-file-attr (source-file stream)
   (let* ((name-index (pool-name "SourceFile"))
@@ -961,43 +926,6 @@
     (write-u2 0 stream) ; start_pc
     (write-u2 *source-line-number* stream)))
 
-(defun write-code-attr (method stream)
-  (declare (optimize speed))
-  (declare (type stream stream))
-  (let* ((name-index (pool-name "Code"))
-         (code (method-code method))
-         (code-length (length code))
-         (line-number-available-p (and (fixnump *source-line-number*)
-                                       (plusp *source-line-number*)))
-         (length (+ code-length 12
-                    (* (length (method-handlers method)) 8)
-                    (if line-number-available-p 12 0)))
-         (max-stack (or (method-max-stack method) 20))
-         (max-locals (or (method-max-locals method) 1)))
-    (write-u2 name-index stream)
-    (write-u4 length stream)
-    (write-u2 max-stack stream)
-    (write-u2 max-locals stream)
-    (write-u4 code-length stream)
-    (dotimes (i code-length)
-      (declare (type index i))
-      (write-u1 (the (unsigned-byte 8) (svref code i)) stream))
-    (write-exception-table method stream)
-    (cond (line-number-available-p
-           ; attributes count
-           (write-u2 1 stream)
-           (write-line-number-table stream))
-          (t
-           ; attributes count
-           (write-u2 0 stream)))))
-
-(defun write-method (method stream)
-  (declare (optimize speed))
-  (write-u2 (or (method-access-flags method) #x1) stream) ; access flags
-  (write-u2 (method-name-index method) stream)
-  (write-u2 (method-descriptor-index method) stream)
-  (write-u2 1 stream) ; attributes count
-  (write-code-attr method stream))
 
 
 (defknown declare-field (t t t) t)
@@ -6890,6 +6818,7 @@
                                         (abcl-class-file-lambda-name class-file)
                                         (abcl-class-file-lambda-list class-file))))
     (pool-name "Code") ; Must be in pool!
+    (class-add-method class-file constructor)
 
     (when *file-compilation*
       (pool-name "SourceFile") ; Must be in pool!
@@ -6899,7 +6828,8 @@
       (pool-name "LineNumberTable")) ; Must be in pool!
     (dolist (field (class-file-fields class-file))
       (finalize-field field class-file))
-    (finalize-method constructor class-file)
+    (dolist (method (class-file-methods class-file))
+      (finalize-method method class-file))
 
     (write-u4 #xCAFEBABE stream)
     (write-u2 3 stream)
@@ -6917,11 +6847,10 @@
     (dolist (field (class-file-fields class-file))
       (write-field field stream))
     ;; methods count
-    (write-u2 (1+ (length (abcl-class-file-methods class-file))) stream)
+    (write-u2 (length (abcl-class-file-methods class-file)) stream)
     ;; methods
     (dolist (method (abcl-class-file-methods class-file))
-      (write-method method stream))
-    (!write-method constructor stream)
+      (!write-method method stream))
     ;; attributes count
     (cond (*file-compilation*
 	   ;; attributes count
@@ -6996,20 +6925,21 @@
          (*child-p* (not (null (compiland-parent compiland))))
 
          (arg-types (analyze-args compiland))
-         (execute-method (make-method :name "execute"
-                                      :descriptor (apply #'descriptor
-                                                         +lisp-object+
-                                                         arg-types)))
+         (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)
-         (*handlers* ())
          (*visible-variables* *visible-variables*)
 
          (*thread* nil)
          (*initialize-thread-var* nil)
          (label-START (gensym)))
 
+    (class-add-method class-file method)
+
     (dolist (var (compiland-arg-vars compiland))
       (push var *visible-variables*))
     (dolist (var (compiland-free-specials compiland))
@@ -7191,32 +7121,9 @@
 	    +lisp-primitive+))
 
     (setf (abcl-class-file-lambda-list class-file) args)
-    (setf (method-max-locals execute-method) *registers-allocated*)
-    (push execute-method (abcl-class-file-methods class-file))
-
-
-    ;;;  Move here
-    (setf *code* (finalize-code *code*
-                                (nconc (mapcar #'handler-from *handlers*)
-                                       (mapcar #'handler-to *handlers*)
-                                       (mapcar #'handler-code *handlers*)) t))
-
-    (setf (method-max-stack execute-method)
-          (analyze-stack *code* (mapcar #'handler-code *handlers*)))
-    (setf (method-code execute-method) (code-bytes *code*))
-
-    ;; Remove handler if its protected range is empty.
-    (setf *handlers*
-          (delete-if (lambda (handler)
-                       (eql (symbol-value (handler-from handler))
-                            (symbol-value (handler-to handler))))
-                     *handlers*))
-    ;;; to here
-    ;;; To a separate function which is part of class file finalization
-    ;;;  when we have a section of class-file-generation centered code
-
+    (setf (code-max-locals code) *registers-allocated*)
+    (setf (code-code code) *code*))
 
-    (setf (method-handlers execute-method) (nreverse *handlers*)))
   t)
 
 (defun p2-with-inline-code (form target representation)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Fri Aug 13 16:25:20 2010
@@ -447,7 +447,7 @@
           (205 ; CLEAR-VALUES
            (dolist (instruction
                      (list
-                      (inst 'aload *thread*)
+                      (inst 'aload (car (instruction-args instruction)))
                       (inst 'aconst_null)
                       (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
                                                       +lisp-object-array+)))))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Aug 13 16:25:20 2010
@@ -229,16 +229,6 @@
 ;; Total number of registers allocated.
 (defvar *registers-allocated* 0)
 
-(defvar *handlers* ())
-
-(defstruct handler
-  from       ;; label indicating the start of the protected block
-  to         ;; label indicating the end of the protected block
-  code       ;; label to jump to if the specified exception occurs
-  catch-type ;; pool index of the class name of the exception, or 0 (zero)
-             ;; for 'all'
-  )
-
 ;; Variables visible at the current point of compilation.
 (defvar *visible-variables* nil
   "All variables visible to the form currently being



From ehuelsmann at common-lisp.net  Fri Aug 13 21:10:40 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 13 Aug 2010 17:10:40 -0400
Subject: [armedbear-cvs] r12895 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ok1WS-0003wj-A4@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug 13 17:10:39 2010
New Revision: 12895

Log:
Remove exclamation marks which were in place to avoid naming
conflicts; the conflicting names have been deleted from pass2 now.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 13 17:10:39 2010
@@ -796,7 +796,7 @@
 (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
+         (method (make-method :constructor :void nil
                                :flags '(:public)))
          (code (method-add-code method))
          req-params-register
@@ -3808,7 +3808,7 @@
 
 (defmacro with-temp-class-file (pathname class-file lambda-list &body body)
   `(let* ((,pathname (make-temp-file))
-	  (,class-file (make-class-file :pathname ,pathname
+	  (,class-file (make-abcl-class-file :pathname ,pathname
                                              :lambda-list ,lambda-list)))
      (unwind-protect
 	  (progn , at body)
@@ -3820,13 +3820,13 @@
          (lambda-list (cadr (compiland-lambda-expression compiland))))
     (cond (*file-compilation*
            (let* ((pathname (funcall *pathnames-generator*))
-                  (class-file (make-class-file :pathname pathname
+                  (class-file (make-abcl-class-file :pathname pathname
                                                :lambda-list lambda-list)))
              (with-open-class-file (f class-file)
                (set-compiland-and-write-class class-file compiland f))
              (setf (local-function-class-file local-function) class-file)))
           (t
-           (let ((class-file (make-class-file :lambda-list lambda-list)))
+           (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
              (with-open-stream (stream (sys::%make-byte-array-output-stream))
                (set-compiland-and-write-class class-file compiland stream)
                (setf (local-function-class-file local-function) class-file)
@@ -3854,8 +3854,8 @@
          (lambda-list (cadr (compiland-lambda-expression compiland))))
     (cond (*file-compilation*
            (let* ((pathname (funcall *pathnames-generator*))
-                  (class-file (make-class-file :pathname pathname
-                                               :lambda-list lambda-list)))
+                  (class-file (make-abcl-class-file :pathname pathname
+                                                    :lambda-list lambda-list)))
              (with-open-class-file (f class-file)
                (set-compiland-and-write-class class-file compiland f))
              (setf (local-function-class-file local-function) class-file)
@@ -3863,7 +3863,7 @@
                (emit-make-compiled-closure-for-labels
                 local-function compiland g))))
           (t
-           (let ((class-file (make-class-file :lambda-list lambda-list)))
+           (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
              (with-open-stream (stream (sys::%make-byte-array-output-stream))
                (set-compiland-and-write-class class-file compiland stream)
                (setf (local-function-class-file local-function) class-file)
@@ -3916,8 +3916,8 @@
     (aver (null (compiland-class-file compiland)))
     (cond (*file-compilation*
            (setf (compiland-class-file compiland)
-                 (make-class-file :pathname (funcall *pathnames-generator*)
-                                  :lambda-list lambda-list))
+                 (make-abcl-class-file :pathname (funcall *pathnames-generator*)
+                                       :lambda-list lambda-list))
            (let ((class-file (compiland-class-file compiland)))
 	     (with-open-class-file (f class-file)
 	       (compile-and-write-to-stream class-file compiland f))
@@ -3927,7 +3927,7 @@
                    +lisp-object+)))
           (t
            (setf (compiland-class-file compiland)
-                 (make-class-file :lambda-list lambda-list))
+                 (make-abcl-class-file :lambda-list lambda-list))
            (with-open-stream (stream (sys::%make-byte-array-output-stream))
              (compile-and-write-to-stream (compiland-class-file compiland)
                                           compiland stream)
@@ -6850,7 +6850,7 @@
     (write-u2 (length (abcl-class-file-methods class-file)) stream)
     ;; methods
     (dolist (method (abcl-class-file-methods class-file))
-      (!write-method method stream))
+      (write-method method stream))
     ;; attributes count
     (cond (*file-compilation*
 	   ;; attributes count
@@ -6925,7 +6925,7 @@
          (*child-p* (not (null (compiland-parent compiland))))
 
          (arg-types (analyze-args compiland))
-         (method (!make-method "execute" +lisp-object+ arg-types
+         (method (make-method "execute" +lisp-object+ arg-types
                                :flags '(:final :public)))
          (code (method-add-code method))
          (*current-code-attribute* code)
@@ -7111,7 +7111,9 @@
                                    +lisp-object-array+)))
         (astore (compiland-argument-register compiland)))
 
-      (maybe-initialize-thread-var)
+      (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)
@@ -7180,25 +7182,26 @@
 to derive a Java class name from."
   (aver (eq (car form) 'LAMBDA))
   (catch 'compile-defun-abort
-    (let* ((class-file (make-class-file :pathname filespec
-                                        :lambda-name name
-                                        :lambda-list (cadr form)))
+    (let* ((class-file (make-abcl-class-file :pathname filespec
+                                             :lambda-name name
+                                             :lambda-list (cadr form)))
            (*compiler-error-bailout*
             `(lambda ()
-               (compile-1 (make-compiland :name ',name
-                                          :lambda-expression (make-compiler-error-form ',form)
-                                          :class-file
-                                          (make-class-file :pathname ,filespec
-                                                           :lambda-name ',name
-                                                           :lambda-list (cadr ',form)))
-			  ,stream)))
+               (compile-1
+                (make-compiland :name ',name
+                                :lambda-expression (make-compiler-error-form ',form)
+                                :class-file
+                                (make-abcl-class-file :pathname ,filespec
+                                                      :lambda-name ',name
+                                                      :lambda-list (cadr ',form)))
+                ,stream)))
            (*compile-file-environment* environment))
-        (compile-1 (make-compiland :name name
-                                   :lambda-expression
-                                   (precompiler:precompile-form form t
-                                                                environment)
-                                   :class-file class-file)
-		   stream))))
+      (compile-1 (make-compiland :name name
+                                 :lambda-expression
+                                 (precompiler:precompile-form form t
+                                                              environment)
+                                 :class-file class-file)
+                 stream))))
 
 (defvar *catch-errors* t)
 

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Fri Aug 13 17:10:39 2010
@@ -503,7 +503,7 @@
     (constant-index entry)))
 
 (defstruct (class-file (:constructor
-                        !make-class-file (class superclass access-flags)))
+                        make-class-file (class superclass access-flags)))
   "Holds the components of a class file."
   (constants (make-pool))
   access-flags
@@ -533,14 +533,14 @@
 (defun class-methods-by-name (class name)
   "Returns all methods which have `name'."
   (remove name (class-file-methods class)
-          :test-not #'string= :key #'!method-name))
+          :test-not #'string= :key #'method-name))
 
 (defun class-method (class name return &rest args)
   "Return the method which is (uniquely) identified by its name AND descriptor."
   (let ((return-and-args (cons return args)))
     (find-if #'(lambda (c)
-                 (and (string= (!method-name c) name)
-                      (equal (!method-descriptor c) return-and-args)))
+                 (and (string= (method-name c) name)
+                      (equal (method-descriptor c) return-and-args)))
              (class-file-methods class))))
 
 (defun class-add-attribute (class attribute)
@@ -673,9 +673,10 @@
   (write-constants (class-file-constants class) stream)
   ;; flags
   (write-u2  (class-file-access-flags class) stream)
-  ;; class name
 
+  ;; class name
   (write-u2 (class-file-class class) stream)
+
   ;; superclass
   (write-u2 (class-file-superclass class) stream)
 
@@ -690,7 +691,7 @@
   ;; methods
   (write-u2 (length (class-file-methods class)) stream)
   (dolist (method (class-file-methods class))
-    (!write-method method stream))
+    (write-method method stream))
 
   ;; attributes
   (write-attributes (class-file-attributes class) stream))
@@ -831,8 +832,8 @@
   (write-attributes (field-attributes field) stream))
 
 
-(defstruct (method (:constructor %!make-method)
-                   (:conc-name !method-))
+(defstruct (method (:constructor %make-method)
+                   (:conc-name method-))
   "Holds information on the properties of methods in the class(-file)."
   access-flags
   name
@@ -854,16 +855,16 @@
      "<init>")
     (t name)))
 
-(defun !make-method (name return args &key (flags '(:public)))
+(defun make-method (name return args &key (flags '(:public)))
   "Creates a method for addition to a class file."
-  (%!make-method :descriptor (cons return args)
+  (%make-method :descriptor (cons return args)
                 :access-flags flags
                 :name name))
 
 (defun method-add-attribute (method attribute)
   "Add `attribute' to the list of attributes of `method',
 returning `attribute'."
-  (push attribute (!method-attributes method))
+  (push attribute (method-attributes method))
   attribute)
 
 (defun method-add-code (method)
@@ -871,8 +872,8 @@
 returning the created attribute."
   (method-add-attribute
    method
-   (make-code-attribute (+ (length (cdr (!method-descriptor method)))
-                           (if (member :static (!method-access-flags method))
+   (make-code-attribute (+ (length (cdr (method-descriptor method)))
+                           (if (member :static (method-access-flags method))
                                0 1))))) ;; 1 == implicit 'this'
 
 (defun method-ensure-code (method)
@@ -885,29 +886,29 @@
 
 (defun method-attribute (method name)
   "Returns the first attribute of `method' with `name'."
-  (find name (!method-attributes method)
+  (find name (method-attributes method)
         :test #'string= :key #'attribute-name))
 
 
 (defun finalize-method (method class)
   "Prepares `method' for serialization."
   (let ((pool (class-file-constants class)))
-    (setf (!method-access-flags method)
-          (map-flags (!method-access-flags method))
-          (!method-descriptor method)
-          (pool-add-utf8 pool (apply #'descriptor (!method-descriptor method)))
-          (!method-name method)
-          (pool-add-utf8 pool (map-method-name (!method-name method)))))
-  (finalize-attributes (!method-attributes method) nil class))
+    (setf (method-access-flags method)
+          (map-flags (method-access-flags method))
+          (method-descriptor method)
+          (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
+          (method-name method)
+          (pool-add-utf8 pool (map-method-name (method-name method)))))
+  (finalize-attributes (method-attributes method) nil class))
 
 
-(defun !write-method (method stream)
+(defun write-method (method stream)
   "Write class file representation of `method' to `stream'."
-  (write-u2 (!method-access-flags method) stream)
-  (write-u2 (!method-name method) stream)
-  ;;(sys::%format t "method-name: ~a~%" (!method-name method))
-  (write-u2 (!method-descriptor method) stream)
-  (write-attributes (!method-attributes method) stream))
+  (write-u2 (method-access-flags method) stream)
+  (write-u2 (method-name method) stream)
+  ;;(sys::%format t "method-name: ~a~%" (method-name method))
+  (write-u2 (method-descriptor method) stream)
+  (write-attributes (method-attributes method) stream))
 
 (defstruct attribute
   "Parent attribute structure to be included into other attributes, mainly
@@ -950,8 +951,8 @@
 (defstruct (code-attribute (:conc-name code-)
                            (:include attribute
                                      (name "Code")
-                                     (finalizer #'!finalize-code)
-                                     (writer #'!write-code))
+                                     (finalizer #'finalize-code-attribute)
+                                     (writer #'write-code-attribute))
                            (:constructor %make-code-attribute))
   "The attribute containing the actual JVM byte code;
 an attribute of a method."
@@ -981,7 +982,7 @@
   (setf (code-labels code)
         (acons label offset (code-labels code))))
 
-(defun !finalize-code (code parent class)
+(defun finalize-code-attribute (code parent class)
   "Prepares the `code' attribute for serialization, within method `parent'."
   (declare (ignore parent))
   (let* ((handlers (code-exception-handlers code))
@@ -999,6 +1000,12 @@
       (setf (code-code code) c
             (code-labels code) labels)))
 
+  (setf (code-exception-handlers code)
+        (remove-if #'(lambda (h)
+                       (eql (code-label-offset code (exception-start-pc h))
+                            (code-label-offset code (exception-end-pc h))))
+                   (code-exception-handlers code)))
+
   (dolist (exception (code-exception-handlers code))
     (setf (exception-start-pc exception)
           (code-label-offset code (exception-start-pc exception))
@@ -1014,7 +1021,7 @@
 
   (finalize-attributes (code-attributes code) code class))
 
-(defun !write-code (code stream)
+(defun write-code-attribute (code stream)
   "Writes the attribute `code' to `stream'."
   ;;(sys::%format t "max-stack: ~a~%" (code-max-stack code))
   (write-u2 (code-max-stack code) stream)
@@ -1085,7 +1092,7 @@
   "An attribute of a field of primitive type.
 
 "
-  
+  ;;; ### TODO
   )
 
 
@@ -1129,12 +1136,10 @@
 (defun save-code-specials (code)
   (setf (code-code code) *code*
         (code-max-locals code) *registers-allocated*
-;;        (code-exception-handlers code) *handlers*
         (code-current-local code) *register*))
 
 (defun restore-code-specials (code)
   (setf *code* (code-code code)
-;;        *handlers* (code-exception-handlers code)
         *registers-allocated* (code-max-locals code)
         *register* (code-current-local code)))
 

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Aug 13 17:10:39 2010
@@ -150,7 +150,7 @@
                                         (java:jstatic "randomUUID"
                                                       "java.util.UUID"))))))
 
-(defun make-class-file (&key pathname lambda-name lambda-list)
+(defun make-abcl-class-file (&key pathname lambda-name lambda-list)
   "Creates a `class-file' structure. If `pathname' is non-NIL, it's
 used to derive a class name. If it is NIL, a random one created
 using `make-unique-class-name'."



From ehuelsmann at common-lisp.net  Fri Aug 13 21:51:27 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 13 Aug 2010 17:51:27 -0400
Subject: [armedbear-cvs] r12896 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ok29v-0006bH-Dm@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug 13 17:51:26 2010
New Revision: 12896

Log:
Add source file and line number attributes according to the
new generator structure.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 13 17:51:26 2010
@@ -6939,6 +6939,10 @@
          (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*))

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Fri Aug 13 17:51:26 2010
@@ -1208,14 +1208,15 @@
   )
 
 (defstruct line-number
-  start-pc  ;; a label, before finalization
+  start-pc  ;; a label, before finalization, or 0 for "start of function"
   line)
 
 (defun finalize-line-numbers (line-numbers code class)
   (declare (ignorable code class))
   (dolist (line-number (line-numbers-table line-numbers))
-    (setf (line-number-start-pc line-number)
-          (code-label-offset code (line-number-start-pc line-number)))))
+    (unless (zerop (line-number-start-pc line-number))
+      (setf (line-number-start-pc line-number)
+            (code-label-offset code (line-number-start-pc line-number))))))
 
 (defun write-line-numbers (line-numbers stream)
   (write-u2 (length (line-numbers-table line-numbers)) stream)
@@ -1223,7 +1224,9 @@
     (write-u2 (line-number-start-pc line-number) stream)
     (write-u2 (line-number-line line-number) stream)))
 
-
+(defun line-numbers-add-line (line-numbers start-pc line)
+  (push (make-line-number :start-pc start-pc :line line)
+        (line-numbers-table line-numbers)))
 
 (defstruct (local-variables-attribute
              (:conc-name local-var-)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Aug 13 17:51:26 2010
@@ -161,6 +161,11 @@
                                             :class class-name
                                             :lambda-name lambda-name
                                             :lambda-list lambda-list)))
+    (when *file-compilation*
+      (let ((source-attribute
+             (make-source-file-attribute
+              :filename (file-namestring *compile-file-truename*))))
+        (class-add-attribute class-file source-attribute)))
     class-file))
 
 (defmacro with-class-file (class-file &body body)



From ehuelsmann at common-lisp.net  Fri Aug 13 23:31:56 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Fri, 13 Aug 2010 19:31:56 -0400
Subject: [armedbear-cvs] r12897 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Ok3jA-0005jb-GB@common-lisp.net>

Author: ehuelsmann
Date: Fri Aug 13 19:31:55 2010
New Revision: 12897

Log:
Use the new generator's WRITE-CLASS-FILE function,
axing other WRITE-* methods from pass2.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 13 19:31:55 2010
@@ -797,7 +797,7 @@
   (let* ((*compiler-debug* nil)
          ;; We don't normally need to see debugging output for constructors.
          (method (make-method :constructor :void nil
-                               :flags '(:public)))
+                              :flags '(:public)))
          (code (method-add-code method))
          req-params-register
          opt-params-register
@@ -907,25 +907,15 @@
     method))
 
 
-(defun write-source-file-attr (source-file stream)
-  (let* ((name-index (pool-name "SourceFile"))
-         (source-file-index (pool-name source-file)))
-    (write-u2 name-index stream)
-    ;; "The value of the attribute_length item of a SourceFile_attribute
-    ;; structure must be 2."
-    (write-u4 2 stream)
-    (write-u2 source-file-index stream)))
-
 (defvar *source-line-number* nil)
 
-(defun write-line-number-table (stream)
-  (let* ((name-index (pool-name "LineNumberTable")))
-    (write-u2 name-index stream)
-    (write-u4 6 stream) ; "the length of the attribute, excluding the initial six bytes"
-    (write-u2 1 stream) ; number of entries
-    (write-u2 0 stream) ; start_pc
-    (write-u2 *source-line-number* stream)))
 
+(defun write-class-file (class stream)
+  (class-add-method class (make-constructor (class-file-superclass class)
+                                            (abcl-class-file-lambda-name class)
+                                            (abcl-class-file-lambda-list class)))
+  (finalize-class-file class)
+  (!write-class-file class stream))
 
 
 (defknown declare-field (t t t) t)
@@ -1203,7 +1193,7 @@
   (declare-with-hashtable
    local-function *declared-functions* ht g
    (setf g (symbol-name (gensym "LFUN")))
-   (let* ((class-name (abcl-class-file-class
+   (let* ((class-name (abcl-class-file-class-name
                        (local-function-class-file local-function)))
           (*code* *static-code*))
      ;; fixme *declare-inline*
@@ -3799,6 +3789,7 @@
     (let ((*current-compiland* compiland))
       (with-saved-compiler-policy
 	  (p2-compiland compiland)
+;;        (finalize-class-file (compiland-class-file compiland))
 	(write-class-file (compiland-class-file compiland) stream)))))
 
 (defun set-compiland-and-write-class (class-file compiland stream)
@@ -3821,7 +3812,7 @@
     (cond (*file-compilation*
            (let* ((pathname (funcall *pathnames-generator*))
                   (class-file (make-abcl-class-file :pathname pathname
-                                               :lambda-list lambda-list)))
+                                                    :lambda-list lambda-list)))
              (with-open-class-file (f class-file)
                (set-compiland-and-write-class class-file compiland f))
              (setf (local-function-class-file local-function) class-file)))
@@ -6809,59 +6800,6 @@
 			 :if-exists :supersede)
      , at body))
 
-(defun write-class-file (class-file stream)
-  (let* ((super (abcl-class-file-superclass class-file))
-         (this (abcl-class-file-class class-file))
-         (this-index (pool-class this))
-         (super-index (pool-class super))
-         (constructor (make-constructor super
-                                        (abcl-class-file-lambda-name class-file)
-                                        (abcl-class-file-lambda-list class-file))))
-    (pool-name "Code") ; Must be in pool!
-    (class-add-method class-file constructor)
-
-    (when *file-compilation*
-      (pool-name "SourceFile") ; Must be in pool!
-      (pool-name (file-namestring *compile-file-truename*)))
-    (when (and (boundp '*source-line-number*)
-               (fixnump *source-line-number*))
-      (pool-name "LineNumberTable")) ; Must be in pool!
-    (dolist (field (class-file-fields class-file))
-      (finalize-field field class-file))
-    (dolist (method (class-file-methods class-file))
-      (finalize-method method class-file))
-
-    (write-u4 #xCAFEBABE stream)
-    (write-u2 3 stream)
-    (write-u2 45 stream)
-    (write-constants *pool* stream)
-    ;; access flags
-    (write-u2 #x21 stream)
-    (write-u2 this-index stream)
-    (write-u2 super-index stream)
-    ;; interfaces count
-    (write-u2 0 stream)
-    ;; fields count
-    (write-u2 (length (class-file-fields class-file)) stream)
-    ;; fields
-    (dolist (field (class-file-fields class-file))
-      (write-field field stream))
-    ;; methods count
-    (write-u2 (length (abcl-class-file-methods class-file)) stream)
-    ;; methods
-    (dolist (method (abcl-class-file-methods class-file))
-      (write-method method stream))
-    ;; attributes count
-    (cond (*file-compilation*
-	   ;; attributes count
-	   (write-u2 1 stream)
-	   ;; attributes table
-	   (write-source-file-attr (file-namestring *compile-file-truename*)
-				   stream))
-	  (t
-	   ;; attributes count
-	   (write-u2 0 stream)))
-    stream))
 
 (defknown p2-compiland-process-type-declarations (list) t)
 (defun p2-compiland-process-type-declarations (body)
@@ -7130,6 +7068,7 @@
     (setf (code-max-locals code) *registers-allocated*)
     (setf (code-code code) *code*))
 
+
   t)
 
 (defun p2-with-inline-code (form target representation)
@@ -7172,6 +7111,7 @@
       ;; Pass 2.
       (with-class-file (compiland-class-file compiland)
         (p2-compiland compiland)
+;;        (finalize-class-file (compiland-class-file compiland))
         (write-class-file (compiland-class-file compiland) stream)))))
 
 (defvar *compiler-error-bailout*)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Aug 13 19:31:55 2010
@@ -121,6 +121,7 @@
 (defstruct (abcl-class-file (:include class-file)
                             (:constructor %make-abcl-class-file))
   pathname ; pathname of output file
+  class-name
   lambda-name
   lambda-list ; as advertised
   static-code
@@ -158,9 +159,11 @@
                          (class-name-from-filespec  pathname)
                          (make-unique-class-name)))
          (class-file (%make-abcl-class-file :pathname pathname
-                                            :class class-name
+                                            :class class-name ; to be finalized
+                                            :class-name class-name
                                             :lambda-name lambda-name
-                                            :lambda-list lambda-list)))
+                                            :lambda-list lambda-list
+                                            :access-flags '(:public :final))))
     (when *file-compilation*
       (let ((source-attribute
              (make-source-file-attribute



From mevenson at common-lisp.net  Sun Aug 15 17:24:49 2010
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sun, 15 Aug 2010 13:24:49 -0400
Subject: [armedbear-cvs] r12898 - trunk/abcl/src/org/armedbear/lisp
Message-ID: <E1Okgwz-0002n1-1K@common-lisp.net>

Author: mevenson
Date: Sun Aug 15 13:24:48 2010
New Revision: 12898

Log:
Fix documentation typo.



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

Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Sun Aug 15 13:24:48 2010
@@ -663,7 +663,7 @@
    *
    * </tt></pre>
    *
-   * After the two above calls <tt>cache</tt> will contain tree keys:
+   * After the two above calls <tt>cache</tt> will contain three keys:
    * <pre>
    * { class FIXNUM, EqlSpecialization('SYMBOL) }
    * { class SYMBOL, EqlSpecialization('SYMBOL) }



From mevenson at common-lisp.net  Sun Aug 15 19:35:45 2010
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sun, 15 Aug 2010 15:35:45 -0400
Subject: [armedbear-cvs] r12899 - trunk/abcl
Message-ID: <E1Okizh-0004cR-4K@common-lisp.net>

Author: mevenson
Date: Sun Aug 15 15:35:43 2010
New Revision: 12899

Log:
Fix typo in ABCL-TEST-LISP definition; add #+abcl conditional

The non-ABCL specific tests could now be run be other Lisp
implementations (tested with sbcl-1.0.39).



Modified:
   trunk/abcl/abcl.asd

Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd	(original)
+++ trunk/abcl/abcl.asd	Sun Aug 15 15:35:43 2010
@@ -33,14 +33,19 @@
                      ((:file "compiler-tests")
                       (:file "condition-tests")
                       (:file "metaclass")
+                      #+abcl
                       (:file "mop-tests-setup")
+                      #+abcl
                       (:file "mop-tests" :depends-on ("mop-tests-setup"))
                       (:file "file-system-tests")
-                      (:file "jar-pathname" :depend-on ("pathname-test"))
+                      #+abcl
+                      (:file "jar-pathname" :depends-on
+                             ("pathname-tests"))
+                      #+abcl
                       (:file "url-pathname")
                       (:file "math-tests")
                       (:file "misc-tests")
-                      (:file "bugs")
+                      (:file "bugs" :depends-on ("file-system-tests"))
                       (:file "pathname-tests")))))
 
 (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp))))



From mevenson at common-lisp.net  Sun Aug 15 19:56:22 2010
From: mevenson at common-lisp.net (Mark Evenson)
Date: Sun, 15 Aug 2010 15:56:22 -0400
Subject: [armedbear-cvs] r12900 - trunk/abcl
Message-ID: <E1OkjJe-0005rA-8R@common-lisp.net>

Author: mevenson
Date: Sun Aug 15 15:56:21 2010
New Revision: 12900

Log:
Correct README language.



Modified:
   trunk/abcl/README

Modified: trunk/abcl/README
==============================================================================
--- trunk/abcl/README	(original)
+++ trunk/abcl/README	Sun Aug 15 15:56:21 2010
@@ -36,10 +36,10 @@
 RUNNING FROM BINARY RELEASE
 ===========================
 
-After you have downloaded a binary release archive, unzip or untar it
-into its own directory. To run ABCL directly from this directory, make
-sure Java (version 1.5 or up) is in your shell's path. Then issue
-following command
+After you have downloaded a binary release archive unpack it into its
+own directory. To run ABCL directly from this directory, make sure
+Java (version 1.5 or up) is in your shell's path. Then issue following
+command
 
     cmd$ java -jar abcl.jar
 
@@ -57,21 +57,20 @@
 BUILDING FROM SOURCE RELEASE
 ============================
 
-If you want to build ABCL forom source the preferred (and most tested
-way) is to use the Ant build tool.
+There are three ways to build ABCL from the source release with the
+preferred (and most tested way) is to being to use the Ant build tool:
 
-1. Use the Ant build tool for Java environments.  
+* Use the Ant build tool for Java environments.  
 
-2. Use the Netbeans 6.x IDE to open ABCL as a project.
+* Use the Netbeans 6.x IDE to open ABCL as a project.
 
-3. Bootstrap ABCL using a Common Lisp implementation. Supported
-   implementations for this process: SBCL, CMUCL, OpenMCL, Allegro
-   CL, LispWorks or CLISP.
+* Bootstrap ABCL using a Common Lisp implementation. Supported
+  implementations for this process: SBCL, CMUCL, OpenMCL, Allegro
+  CL, LispWorks or CLISP.
 
-
-In both cases you need a supported JDK version (1.5 and 1.6 have been
-tested).  Just the JRE isn't enough, as you need javac to compile
-files.
+In all cases you need a Java 5 or later JDK (JDK 1.5 and 1.6 have been
+tested).  Just the JRE isn't enough, as you need the Java compiler
+('javac') to compile the Java source of the ABCL implementation.
 
 
 Using Ant
@@ -99,7 +98,9 @@
 --------------
 
 Obtain and install the [Netbeans IDE][2]. One should be able to open
-the ABCL directory as a project in the Netbeans 6.x application.
+the ABCL directory as a project in the Netbeans 6.x application,
+whereupon the usual build, run, and debug targets as invoked in the
+GUI are available.
 
 [2]: http://netbeans.org/downloads/
 
@@ -113,20 +114,29 @@
 two methods, but it still may be of interest to those who absolutely
 don't want to know anything about Java.
 
-First, copy the file 'customizations.lisp.in' to customization.lisp', in the
-directory containing this README file, editing to suit your situation,
-paying attention to the comments in the file.  The ciritical point is
-to have **JDK** point to the root of the Java Development Kit.  There
-should be a `**JDK**/bin/javac' java compiler present.  
-
-Use ./build-from-lisp.sh <lisp-of-choice>, e.g.
+First, copy the file 'customizations.lisp.in' to customization.lisp',
+in the directory containing this README file, editing to suit your
+situation, paying attention to the comments in the file.  The critical
+step is to have Lisp special variable '*JDK*' point to the root of the
+Java Development Kit.  Underneath the directory referenced by the
+value of '*JDK*' there should be an exectuable Java compiler in
+'bin/javac' ('bin/java.exe' under Windows).
+
+Then, one may either use the 'build-from-lisp.sh' shell script or load
+the necessary files into your Lisp image by hand.
+
+** Using the 'build-from-lisp.sh' script
+
+Under UNIX-like systems, you may simply invoke the
+'build-from-lisp.sh' script as './build-from-lisp.sh
+<lisp-of-choice>', e.g.
 
     unix$ ./build-from-lisp.sh sbcl
 
-Use abcl.bat on Windows or ./abcl on Unix to start ABCL.
-Note: abcl.bat and abcl contain absolute paths, so you'll need
-to edit them if you move things around after the build.
-
+After a successful build, you may use 'abcl.bat' on Windows or 'abcl'
+on Unix to start ABCL.  Note that this wrappers contain absolute
+paths, so you'll need to edit them if you move things around after the
+build. 
 
 If you're developing on ABCL, you may want to use
 
@@ -140,15 +150,17 @@
 
 This invokes javac separately for each .java file, which avoids running
 into limitations on command line length (but is a lot slower).
+ 
+** Building from another Lisp by hand
 
-There is also an ASDF definition in 'abcl.asd' for BUILD-ABCL which
-can be used to load the necessary Lisp defintions, after which 
-
+There is also an ASDF definition in 'abcl.asd' for the BUILD-ABCL
+which can be used to load the necessary Lisp definitions, after which
 
     CL-USER> (build-abcl:build-abcl :clean t :full t)
     
-will build ABCL.    
-
+will build ABCL.  If ASDF isn't present, simply LOAD the
+'customizations.lisp' and 'build-abcl.lisp' files to achieve the same
+effect as loading the ASDF definition.
 
 
 BUGS



From mevenson at common-lisp.net  Fri Aug 20 03:49:16 2010
From: mevenson at common-lisp.net (Mark Evenson)
Date: Thu, 19 Aug 2010 23:49:16 -0400
Subject: [armedbear-cvs] r12901 - trunk/abcl
Message-ID: <E1OmIbU-0003lZ-DL@common-lisp.net>

Author: mevenson
Date: Thu Aug 19 23:49:13 2010
New Revision: 12901

Log:
Include contrib in source release.



Modified:
   trunk/abcl/build.xml

Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml	(original)
+++ trunk/abcl/build.xml	Thu Aug 19 23:49:13 2010
@@ -473,6 +473,10 @@
       <include name="abcl.bat.in"/>
       
       <include name="examples/**"/>
+
+      <include name="contrib/**"/>
+
+      <include name="build-from-lisp.sh"/>
       
       <!-- The remainder of these files are used by the Lisp hosted
            build in 'build-abcl.lisp' but not used by Ant, so include
@@ -480,7 +484,7 @@
       <include name="make-jar.in"/>
       <include name="make-jar.bat.in"/>
 
-      <include name="build-from-lisp.sh"/>
+
 
       <include name="build-abcl.lisp"/>
       <include name="customizations.lisp.in"/>



From vvoutilainen at common-lisp.net  Sat Aug 28 11:09:16 2010
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sat, 28 Aug 2010 07:09:16 -0400
Subject: [armedbear-cvs] r12902 - in trunk/abcl: .
	src/org/armedbear/lisp/util test/lisp/abcl
Message-ID: <E1OpJHg-000071-4O@common-lisp.net>

Author: vvoutilainen
Date: Sat Aug 28 07:09:13 2010
New Revision: 12902

Log:
Fix reading of data containing scandinavian latin1 characters
correctly, and add a simple test for it. The utf-8 test is
just a sanity test so that umlauts as utf-8 aren't broken, the
latin1 test properly fails without this patch and passes
with this patch.


Added:
   trunk/abcl/test/lisp/abcl/latin1-tests.lisp   (contents, props changed)
   trunk/abcl/test/lisp/abcl/latin1-umlauts.txt
   trunk/abcl/test/lisp/abcl/utf8-umlauts.txt
Modified:
   trunk/abcl/abcl.asd
   trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java
   trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java

Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd	(original)
+++ trunk/abcl/abcl.asd	Sat Aug 28 07:09:13 2010
@@ -45,6 +45,7 @@
                       (:file "url-pathname")
                       (:file "math-tests")
                       (:file "misc-tests")
+                      (:file "latin1-tests")
                       (:file "bugs" :depends-on ("file-system-tests"))
                       (:file "pathname-tests")))))
 

Modified: trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java	Sat Aug 28 07:09:13 2010
@@ -45,6 +45,7 @@
 import java.nio.charset.CharsetDecoder;
 import java.nio.charset.CharsetEncoder;
 import java.nio.charset.CoderResult;
+import java.nio.charset.CodingErrorAction;
 
 import org.armedbear.lisp.Debug;
 
@@ -79,6 +80,8 @@
           // we need to be able to unread the byte buffer
         this.stream = new PushbackInputStream(stream, size);
         this.cd = cs.newDecoder();
+        this.cd.onUnmappableCharacter(CodingErrorAction.REPLACE);
+        this.cd.onMalformedInput(CodingErrorAction.REPLACE);
         this.ce = cs.newEncoder();
         bbuf = ByteBuffer.allocate(size);
         bbuf.flip();  // mark the buffer as 'needs refill'
@@ -89,6 +92,8 @@
      */
     public final void setCharset(Charset cs) {
         this.cd = cs.newDecoder();
+        this.cd.onUnmappableCharacter(CodingErrorAction.REPLACE);
+        this.cd.onMalformedInput(CodingErrorAction.REPLACE);
         this.ce = cs.newEncoder();
     }
 
@@ -257,18 +262,23 @@
 
 
         while (cb.remaining() > 0 && notEof) {
+            int oldRemaining = cb.remaining();
             notEof = ensureBbuf(forceRead);
             CoderResult r = cd.decode(bbuf, cb, ! notEof);
-            forceRead = (CoderResult.UNDERFLOW == r);
-
-            if (r.isMalformed()) {
-                throw new RACFMalformedInputException(bbuf.position(),
-                                                      (char)bbuf.get(bbuf.position()),
-                                                      cd.charset().name());
-            } else if (r.isUnmappable()) {
-                // a situation exactly like this is in DecodingReader too
-                Debug.assertTrue(false);
+            if (oldRemaining == cb.remaining()
+                && CoderResult.OVERFLOW == r) {
+                // if this happens, the decoding failed
+                // but the bufs didn't advance. Advance
+                // them manually and do manual replacing,
+                // otherwise we loop endlessly. This occurs
+                // at least when parsing latin1 files with
+                // lowercase o-umlauts in them.
+                // Note that this is at the moment copy-paste
+                // with RandomAccessCharacterFile.read()
+                cb.put('?');
+                bbuf.get();
             }
+            forceRead = (CoderResult.UNDERFLOW == r);
         }
         if (cb.remaining() == len)
             return -1;

Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java	Sat Aug 28 07:09:13 2010
@@ -370,23 +370,23 @@
         boolean decodeWasUnderflow = false;
         boolean atEof = false;
         while ((cbuf.remaining() > 0) && ! atEof) {
-
+            int oldRemaining = cbuf.remaining();
             atEof = ! ensureReadBbuf(decodeWasUnderflow);
             CoderResult r = cdec.decode(bbuf, cbuf, atEof );
+            if (oldRemaining == cbuf.remaining()
+                && CoderResult.OVERFLOW == r) {
+                // if this happens, the decoding failed
+                // but the bufs didn't advance. Advance
+                // them manually and do manual replacing,
+                // otherwise we loop endlessly. This occurs
+                // at least when parsing latin1 files with
+                // lowercase o-umlauts in them
+                // Note that this is at the moment copy-paste
+                // with DecodingReader.read()
+                cbuf.put('?');
+                bbuf.get();
+            }
             decodeWasUnderflow = (CoderResult.UNDERFLOW == r);
-            if (r.isMalformed())
-                // When reading encoded Unicode, we'd expect to require
-                // catching MalformedInput
-                throw new RACFMalformedInputException(bbuf.position(),
-                                                      (char)bbuf.get(bbuf.position()),
-                                                      cset.name());
-            if (r.isUnmappable())
-                // Since we're mapping TO unicode, we'd expect to be able
-                // to map all characters
-                Debug.assertTrue(false);
-            // OVERFLOW is a normal condition:
-            //  it's equal to cbuf.remaining() == 0
-            // ### EHU: really??? EXACTLY equal??
         }
         if (cbuf.remaining() == len) {
             return -1;

Added: trunk/abcl/test/lisp/abcl/latin1-tests.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/abcl/latin1-tests.lisp	Sat Aug 28 07:09:13 2010
@@ -0,0 +1,30 @@
+;;; latin1-tests.lisp
+;;;
+;;; Copyright (C) 2010 Ville Voutilainen
+;;; $Id$
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+(in-package #:abcl.test.lisp)
+
+(deftest normal-utf8.1
+  (load "utf8-umlauts.txt")
+  t)
+
+(deftest latin1.1
+  (load "latin1-umlauts.txt")
+  t)
+
+

Added: trunk/abcl/test/lisp/abcl/latin1-umlauts.txt
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/abcl/latin1-umlauts.txt	Sat Aug 28 07:09:13 2010
@@ -0,0 +1,3 @@
+;; some umlauts: ????????????????????????
+(defun not-so-hard ()
+  (format t "just a debug print~%"))

Added: trunk/abcl/test/lisp/abcl/utf8-umlauts.txt
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/abcl/utf8-umlauts.txt	Sat Aug 28 07:09:13 2010
@@ -0,0 +1,3 @@
+;; some umlauts: ????????????????????????????????????????????????
+(defun not-so-hard ()
+  (format t "just a debug print~%"))



From vvoutilainen at common-lisp.net  Sat Aug 28 11:10:59 2010
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sat, 28 Aug 2010 07:10:59 -0400
Subject: [armedbear-cvs] r12903 - trunk/abcl
Message-ID: <E1OpJJL-00008f-96@common-lisp.net>

Author: vvoutilainen
Date: Sat Aug 28 07:10:58 2010
New Revision: 12903

Log:
Add a changelog entry for the latin1 fix.


Modified:
   trunk/abcl/CHANGES

Modified: trunk/abcl/CHANGES
==============================================================================
--- trunk/abcl/CHANGES	(original)
+++ trunk/abcl/CHANGES	Sat Aug 28 07:10:58 2010
@@ -1,7 +1,17 @@
+Version 0.22
+============
+unreleased
+(??, 2010)
+
+Fixes
+-----
+
+* [svn r12902] Fix reading data with scandinavian latin1 characters
+
 Version 0.21
 ============
 svn://common-lisp.net/project/armedbear/svn/tags/0.21.0/abcl
-(???, 2010)
+(July 24, 2010)
 
 
 Features



From ehuelsmann at common-lisp.net  Sun Aug 29 17:30:06 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 29 Aug 2010 13:30:06 -0400
Subject: [armedbear-cvs] r12904 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Oplhl-00005I-VW@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug 29 13:30:04 2010
New Revision: 12904

Log:
Resolve the WRITE-CLASS-FILE double-use.


Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Aug 29 13:30:04 2010
@@ -515,7 +515,7 @@
           +lisp-symbol+)
     (emit-invokestatic +lisp+ "type_error"
                        (lisp-object-arg-types 2) +lisp-object+)
-    (emit 'pop) ; Needed for JVM stack consistency.
+    (emit 'areturn) ; Needed for JVM stack consistency.
     (label LABEL1))
   t)
 
@@ -910,12 +910,16 @@
 (defvar *source-line-number* nil)
 
 
-(defun write-class-file (class stream)
+(defun finish-class (class stream)
+  "Finalizes the `class' and writes the result to `stream'.
+
+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)))
   (finalize-class-file class)
-  (!write-class-file class stream))
+  (write-class-file class stream))
 
 
 (defknown declare-field (t t t) t)
@@ -3790,7 +3794,7 @@
       (with-saved-compiler-policy
 	  (p2-compiland compiland)
 ;;        (finalize-class-file (compiland-class-file compiland))
-	(write-class-file (compiland-class-file compiland) stream)))))
+	(finish-class (compiland-class-file compiland) stream)))))
 
 (defun set-compiland-and-write-class (class-file compiland stream)
   (setf (compiland-class-file compiland) class-file)
@@ -7085,34 +7089,38 @@
         (*local-functions* *local-functions*)
         (*current-compiland* compiland))
     (with-saved-compiler-policy
-      ;; Pass 1.
-      (p1-compiland compiland)
-      ;; *all-variables* doesn't contain variables which
-      ;; are in an enclosing lexical environment (variable-environment)
-      ;; so we don't need to filter them out
-      (setf *closure-variables*
-            (remove-if #'variable-special-p
-                       (remove-if-not #'variable-used-non-locally-p
-                                                 *all-variables*)))
-      (let ((i 0))
-        (dolist (var (reverse *closure-variables*))
-          (setf (variable-closure-index var) i)
-          (dformat t "var = ~S closure index = ~S~%" (variable-name var)
-                   (variable-closure-index var))
-          (incf i)))
+        ;; Pass 1.
+        (p1-compiland compiland))
+
+    ;; *all-variables* doesn't contain variables which
+    ;; are in an enclosing lexical environment (variable-environment)
+    ;; so we don't need to filter them out
+    (setf *closure-variables*
+          (remove-if #'variable-special-p
+                     (remove-if-not #'variable-used-non-locally-p
+                                    *all-variables*)))
+    (let ((i 0))
+      (dolist (var (reverse *closure-variables*))
+        (setf (variable-closure-index var) i)
+        (dformat t "var = ~S closure index = ~S~%" (variable-name var)
+                 (variable-closure-index var))
+        (incf i)))
 
       ;; Assert that we're not refering to any variables
       ;; we're not allowed to use
-      (assert (= 0
-                 (length (remove-if (complement #'variable-references)
-                                    (remove-if #'variable-references-allowed-p
-                                               *visible-variables*)))))
+
+    (assert (= 0
+               (length (remove-if (complement #'variable-references)
+                                  (remove-if #'variable-references-allowed-p
+                                             *visible-variables*)))))
 
       ;; Pass 2.
-      (with-class-file (compiland-class-file compiland)
+
+    (with-class-file (compiland-class-file compiland)
+      (with-saved-compiler-policy
         (p2-compiland compiland)
-;;        (finalize-class-file (compiland-class-file compiland))
-        (write-class-file (compiland-class-file compiland) stream)))))
+        ;;        (finalize-class-file (compiland-class-file compiland))
+        (finish-class (compiland-class-file compiland) stream)))))
 
 (defvar *compiler-error-bailout*)
 

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Sun Aug 29 13:30:04 2010
@@ -532,12 +532,13 @@
 
 (defun class-methods-by-name (class name)
   "Returns all methods which have `name'."
-  (remove name (class-file-methods class)
+  (remove (map-method-name name) (class-file-methods class)
           :test-not #'string= :key #'method-name))
 
 (defun class-method (class name return &rest args)
   "Return the method which is (uniquely) identified by its name AND descriptor."
-  (let ((return-and-args (cons return args)))
+  (let ((return-and-args (cons return args))
+        (name (map-method-name name)))
     (find-if #'(lambda (c)
                  (and (string= (method-name c) name)
                       (equal (method-descriptor c) return-and-args)))
@@ -661,7 +662,7 @@
         (write-ascii string length stream))))
 
 
-(defun !write-class-file (class stream)
+(defun write-class-file (class stream)
   "Serializes `class' to `stream', after it has been finalized."
 
   ;; header
@@ -845,11 +846,11 @@
   "Methods should be identified by strings containing their names, or,
 be one of two keyword identifiers to identify special methods:
 
- * :class-constructor
+ * :static-initializer
  * :constructor
 "
   (cond
-    ((eq name :class-constructor)
+    ((eq name :static-initializer)
      "<clinit>")
     ((eq name :constructor)
      "<init>")
@@ -859,7 +860,7 @@
   "Creates a method for addition to a class file."
   (%make-method :descriptor (cons return args)
                 :access-flags flags
-                :name name))
+                :name (map-method-name name)))
 
 (defun method-add-attribute (method attribute)
   "Add `attribute' to the list of attributes of `method',
@@ -898,7 +899,7 @@
           (method-descriptor method)
           (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))
           (method-name method)
-          (pool-add-utf8 pool (map-method-name (method-name method)))))
+          (pool-add-utf8 pool (method-name method))))
   (finalize-attributes (method-attributes method) nil class))
 
 
@@ -992,8 +993,12 @@
                             (mapcar #'exception-end-pc handlers)
                             (mapcar #'exception-handler-pc handlers))
                      t)))
-    (setf (code-max-stack code)
-          (analyze-stack c (mapcar #'exception-handler-pc handlers)))
+    (unless (code-max-stack code)
+      (setf (code-max-stack code)
+            (analyze-stack c (mapcar #'exception-handler-pc handlers))))
+    (unless (code-max-locals code)
+      (setf (code-max-locals code)
+            (analyze-locals code)))
     (multiple-value-bind
           (c labels)
         (code-bytes c)
@@ -1143,14 +1148,13 @@
         *registers-allocated* (code-max-locals code)
         *register* (code-current-local code)))
 
-(defmacro with-code-to-method ((class-file method &key (safe-nesting t))
-			       &body body)
+(defmacro with-code-to-method ((class-file method)
+                               &body body)
   (let ((m (gensym))
         (c (gensym)))
     `(progn
-       ,@(when safe-nesting
-           `((when *current-code-attribute*
-               (save-code-specials *current-code-attribute*))))
+       (when *current-code-attribute*
+         (save-code-specials *current-code-attribute*))
        (let* ((,m ,method)
               (,c (method-ensure-code ,method))
               (*pool* (class-file-constants ,class-file))
@@ -1160,12 +1164,10 @@
               (*current-code-attribute* ,c))
          , at body
          (setf (code-code ,c) *code*
-	       (code-current-local ,c) *register*
-;;               (code-exception-handlers ,c) *handlers*
+               (code-current-local ,c) *register*
                (code-max-locals ,c) *registers-allocated*))
-       ,@(when safe-nesting
-           `((when *current-code-attribute*
-               (restore-code-specials *current-code-attribute*)))))))
+       (when *current-code-attribute*
+         (restore-code-specials *current-code-attribute*)))))
 
 
 (defstruct (source-file-attribute (:conc-name source-)



From ehuelsmann at common-lisp.net  Sun Aug 29 18:21:43 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 29 Aug 2010 14:21:43 -0400
Subject: [armedbear-cvs] r12905 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1OpmVj-0003dt-5a@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug 29 14:21:42 2010
New Revision: 12905

Log:
Eliminate SET-COMPILAND-AND-WRITE-CLASS, since it doesn't take care
of most of the other boiler plate.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Aug 29 14:21:42 2010
@@ -3789,17 +3789,13 @@
     (emit-move-from-stack target)))
 
 (defun compile-and-write-to-stream (class-file compiland stream)
+  (setf (compiland-class-file compiland) class-file)
   (with-class-file class-file
     (let ((*current-compiland* compiland))
       (with-saved-compiler-policy
-	  (p2-compiland compiland)
+        (p2-compiland compiland)
 ;;        (finalize-class-file (compiland-class-file compiland))
-	(finish-class (compiland-class-file compiland) stream)))))
-
-(defun set-compiland-and-write-class (class-file compiland stream)
-  (setf (compiland-class-file compiland) class-file)
-  (compile-and-write-to-stream class-file compiland stream))
-
+        (finish-class (compiland-class-file compiland) stream)))))
 
 (defmacro with-temp-class-file (pathname class-file lambda-list &body body)
   `(let* ((,pathname (make-temp-file))
@@ -3818,12 +3814,12 @@
                   (class-file (make-abcl-class-file :pathname pathname
                                                     :lambda-list lambda-list)))
              (with-open-class-file (f class-file)
-               (set-compiland-and-write-class class-file compiland f))
+               (compile-and-write-to-stream class-file compiland f))
              (setf (local-function-class-file local-function) class-file)))
           (t
            (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
              (with-open-stream (stream (sys::%make-byte-array-output-stream))
-               (set-compiland-and-write-class class-file compiland stream)
+               (compile-and-write-to-stream class-file compiland stream)
                (setf (local-function-class-file local-function) class-file)
                (setf (local-function-function local-function)
                      (load-compiled-function
@@ -3852,7 +3848,7 @@
                   (class-file (make-abcl-class-file :pathname pathname
                                                     :lambda-list lambda-list)))
              (with-open-class-file (f class-file)
-               (set-compiland-and-write-class class-file compiland f))
+               (compile-and-write-to-stream class-file compiland f))
              (setf (local-function-class-file local-function) class-file)
              (let ((g (declare-local-function local-function)))
                (emit-make-compiled-closure-for-labels
@@ -3860,7 +3856,7 @@
           (t
            (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
              (with-open-stream (stream (sys::%make-byte-array-output-stream))
-               (set-compiland-and-write-class class-file compiland stream)
+               (compile-and-write-to-stream class-file compiland stream)
                (setf (local-function-class-file local-function) class-file)
                (let ((g (declare-object
                          (load-compiled-function
@@ -3910,10 +3906,9 @@
   (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
     (aver (null (compiland-class-file compiland)))
     (cond (*file-compilation*
-           (setf (compiland-class-file compiland)
-                 (make-abcl-class-file :pathname (funcall *pathnames-generator*)
-                                       :lambda-list lambda-list))
-           (let ((class-file (compiland-class-file compiland)))
+           (let ((class-file (make-abcl-class-file
+                                :pathname (funcall *pathnames-generator*)
+                                :lambda-list lambda-list)))
 	     (with-open-class-file (f class-file)
 	       (compile-and-write-to-stream class-file compiland f))
              (emit-getstatic *this-class*
@@ -3921,10 +3916,9 @@
                                                                 class-file))
                    +lisp-object+)))
           (t
-           (setf (compiland-class-file compiland)
-                 (make-abcl-class-file :lambda-list lambda-list))
            (with-open-stream (stream (sys::%make-byte-array-output-stream))
-             (compile-and-write-to-stream (compiland-class-file compiland)
+             (compile-and-write-to-stream (make-abcl-class-file :lambda-list
+                                                                lambda-list)
                                           compiland stream)
              (emit-load-externalized-object (load-compiled-function
                                     (sys::%get-output-stream-bytes stream))))))



From vvoutilainen at common-lisp.net  Sun Aug 29 20:56:18 2010
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Sun, 29 Aug 2010 16:56:18 -0400
Subject: [armedbear-cvs] r12906 - trunk/abcl
Message-ID: <E1OpovK-0007R5-Cr@common-lisp.net>

Author: vvoutilainen
Date: Sun Aug 29 16:56:16 2010
New Revision: 12906

Log:
Respect CLASSPATH in wrapper scripts.


Modified:
   trunk/abcl/abcl.bat.in
   trunk/abcl/abcl.in

Modified: trunk/abcl/abcl.bat.in
==============================================================================
--- trunk/abcl/abcl.bat.in	(original)
+++ trunk/abcl/abcl.bat.in	Sun Aug 29 16:56:16 2010
@@ -1 +1 @@
-@"@JAVA@" @ABCL_JAVA_OPTIONS@ -cp "@ABCL_CLASSPATH@"  org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9 
+@"@JAVA@" @ABCL_JAVA_OPTIONS@ -cp "@ABCL_CLASSPATH@";"%CLASSPATH%"  org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9 

Modified: trunk/abcl/abcl.in
==============================================================================
--- trunk/abcl/abcl.in	(original)
+++ trunk/abcl/abcl.in	Sun Aug 29 16:56:16 2010
@@ -20,7 +20,7 @@
 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 
 exec @JAVA@ @ABCL_JAVA_OPTIONS@ \
-  -cp  @ABCL_CLASSPATH@ \
+  -cp  @ABCL_CLASSPATH@:"$CLASSPATH" \
   org.armedbear.lisp.Main \
   "$@"
 



From ehuelsmann at common-lisp.net  Sun Aug 29 22:13:31 2010
From: ehuelsmann at common-lisp.net (Erik Huelsmann)
Date: Sun, 29 Aug 2010 18:13:31 -0400
Subject: [armedbear-cvs] r12907 -
	branches/generic-class-file/abcl/src/org/armedbear/lisp
Message-ID: <E1Opq83-0004b7-Ih@common-lisp.net>

Author: ehuelsmann
Date: Sun Aug 29 18:13:30 2010
New Revision: 12907

Log:
Remove WITH-TEMP-CLASS-FILE: it's been long unused.
Integrate CLASS-FILE and STREAM creation into COMPILE-AND-WRITE-TO-STREAM
(which now probably should be renamed) to clean up boiler plate from
its callers.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun Aug 29 18:13:30 2010
@@ -3788,42 +3788,41 @@
     (emit-push-nil)
     (emit-move-from-stack target)))
 
-(defun compile-and-write-to-stream (class-file compiland stream)
-  (setf (compiland-class-file compiland) class-file)
-  (with-class-file class-file
-    (let ((*current-compiland* compiland))
-      (with-saved-compiler-policy
-        (p2-compiland compiland)
-;;        (finalize-class-file (compiland-class-file compiland))
-        (finish-class (compiland-class-file compiland) stream)))))
-
-(defmacro with-temp-class-file (pathname class-file lambda-list &body body)
-  `(let* ((,pathname (make-temp-file))
-	  (,class-file (make-abcl-class-file :pathname ,pathname
-                                             :lambda-list ,lambda-list)))
-     (unwind-protect
-	  (progn , at body)
-       (delete-file pathname))))
+(defun compile-and-write-to-stream (compiland &optional stream)
+  "Creates a class file associated with `compiland`, writing it
+either to stream or the pathname of the class file if `stream' is NIL."
+  (let* ((pathname (funcall *pathnames-generator*))
+         (class-file (make-abcl-class-file
+                      :pathname pathname
+                      :lambda-list
+                      (cadr (compiland-lambda-expression compiland)))))
+    (setf (compiland-class-file compiland) class-file)
+    (with-open-stream (f (or stream
+                             (open pathname :direction :output
+                                   :element-type '(unsigned-byte 8)
+                                   :if-exists :supersede)))
+      (with-class-file class-file
+        (let ((*current-compiland* compiland))
+          (with-saved-compiler-policy
+              (p2-compiland compiland)
+            ;;        (finalize-class-file (compiland-class-file compiland))
+            (finish-class (compiland-class-file compiland) f)))))))
 
 (defknown p2-flet-process-compiland (t) t)
 (defun p2-flet-process-compiland (local-function)
-  (let* ((compiland (local-function-compiland local-function))
-         (lambda-list (cadr (compiland-lambda-expression compiland))))
+  (let* ((compiland (local-function-compiland local-function)))
     (cond (*file-compilation*
-           (let* ((pathname (funcall *pathnames-generator*))
-                  (class-file (make-abcl-class-file :pathname pathname
-                                                    :lambda-list lambda-list)))
-             (with-open-class-file (f class-file)
-               (compile-and-write-to-stream class-file compiland f))
-             (setf (local-function-class-file local-function) class-file)))
-          (t
-           (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
-             (with-open-stream (stream (sys::%make-byte-array-output-stream))
-               (compile-and-write-to-stream class-file compiland stream)
-               (setf (local-function-class-file local-function) class-file)
-               (setf (local-function-function local-function)
-                     (load-compiled-function
-                      (sys::%get-output-stream-bytes stream)))))))))
+           (compile-and-write-to-stream compiland)
+           (setf (local-function-class-file local-function)
+                 (compiland-class-file compiland)))
+          (t
+           (with-open-stream (stream (sys::%make-byte-array-output-stream))
+             (compile-and-write-to-stream compiland stream)
+             (setf (local-function-class-file local-function)
+                   (compiland-class-file compiland))
+             (setf (local-function-function local-function)
+                   (load-compiled-function
+                    (sys::%get-output-stream-bytes stream))))))))
 
 (defun emit-make-compiled-closure-for-labels
     (local-function compiland declaration)
@@ -3841,28 +3840,24 @@
 
 (defknown p2-labels-process-compiland (t) t)
 (defun p2-labels-process-compiland (local-function)
-  (let* ((compiland (local-function-compiland local-function))
-         (lambda-list (cadr (compiland-lambda-expression compiland))))
+  (let* ((compiland (local-function-compiland local-function)))
     (cond (*file-compilation*
-           (let* ((pathname (funcall *pathnames-generator*))
-                  (class-file (make-abcl-class-file :pathname pathname
-                                                    :lambda-list lambda-list)))
-             (with-open-class-file (f class-file)
-               (compile-and-write-to-stream class-file compiland f))
-             (setf (local-function-class-file local-function) class-file)
-             (let ((g (declare-local-function local-function)))
-               (emit-make-compiled-closure-for-labels
-                local-function compiland g))))
+           (compile-and-write-to-stream compiland)
+           (setf (local-function-class-file local-function)
+                 (compiland-class-file compiland))
+           (let ((g (declare-local-function local-function)))
+             (emit-make-compiled-closure-for-labels
+              local-function compiland g)))
           (t
-           (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
-             (with-open-stream (stream (sys::%make-byte-array-output-stream))
-               (compile-and-write-to-stream class-file compiland stream)
-               (setf (local-function-class-file local-function) class-file)
-               (let ((g (declare-object
-                         (load-compiled-function
-                          (sys::%get-output-stream-bytes stream)))))
-                 (emit-make-compiled-closure-for-labels
-                  local-function compiland g))))))))
+           (with-open-stream (stream (sys::%make-byte-array-output-stream))
+             (compile-and-write-to-stream compiland stream)
+             (setf (local-function-class-file local-function)
+                   (compiland-class-file compiland))
+             (let ((g (declare-object
+                       (load-compiled-function
+                        (sys::%get-output-stream-bytes stream)))))
+               (emit-make-compiled-closure-for-labels
+                local-function compiland g)))))))
 
 (defknown p2-flet-node (t t t) t)
 (defun p2-flet-node (block target representation)
@@ -3903,35 +3898,30 @@
       (compile-progn-body body target representation))))
 
 (defun p2-lambda (compiland target)
-  (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
-    (aver (null (compiland-class-file compiland)))
-    (cond (*file-compilation*
-           (let ((class-file (make-abcl-class-file
-                                :pathname (funcall *pathnames-generator*)
-                                :lambda-list lambda-list)))
-	     (with-open-class-file (f class-file)
-	       (compile-and-write-to-stream class-file compiland f))
-             (emit-getstatic *this-class*
-                   (declare-local-function (make-local-function :class-file
-                                                                class-file))
-                   +lisp-object+)))
-          (t
-           (with-open-stream (stream (sys::%make-byte-array-output-stream))
-             (compile-and-write-to-stream (make-abcl-class-file :lambda-list
-                                                                lambda-list)
-                                          compiland stream)
-             (emit-load-externalized-object (load-compiled-function
-                                    (sys::%get-output-stream-bytes stream))))))
-    (cond ((null *closure-variables*))  ; Nothing to do.
-          ((compiland-closure-register *current-compiland*)
-           (duplicate-closure-array *current-compiland*)
-           (emit-invokestatic +lisp+ "makeCompiledClosure"
-                              (list +lisp-object+ +closure-binding-array+)
-                              +lisp-object+))
+  (aver (null (compiland-class-file compiland)))
+  (cond (*file-compilation*
+         (compile-and-write-to-stream compiland)
+         (emit-getstatic *this-class*
+                         (declare-local-function
+                          (make-local-function
+                           :class-file (compiland-class-file compiland)))
+                         +lisp-object+))
+        (t
+         (with-open-stream (stream (sys::%make-byte-array-output-stream))
+           (compile-and-write-to-stream compiland stream)
+           (emit-load-externalized-object (load-compiled-function
+                                           (sys::%get-output-stream-bytes stream))))))
+  (cond ((null *closure-variables*))    ; Nothing to do.
+        ((compiland-closure-register *current-compiland*)
+         (duplicate-closure-array *current-compiland*)
+         (emit-invokestatic +lisp+ "makeCompiledClosure"
+                            (list +lisp-object+ +closure-binding-array+)
+                            +lisp-object+))
                                         ; Stack: compiled-closure
-          (t
-           (aver nil))) ;; Shouldn't happen.
-    (emit-move-from-stack target)))
+        (t
+         (aver nil))) ;; Shouldn't happen.
+
+  (emit-move-from-stack target))
 
 (defknown p2-function (t t t) t)
 (defun p2-function (form target representation)
@@ -6793,9 +6783,9 @@
 
 (defmacro with-open-class-file ((var class-file) &body body)
   `(with-open-file (,var (abcl-class-file-pathname ,class-file)
-			 :direction :output
-			 :element-type '(unsigned-byte 8)
-			 :if-exists :supersede)
+                         :direction :output
+                         :element-type '(unsigned-byte 8)
+                         :if-exists :supersede)
      , at body))
 
 



From vvoutilainen at common-lisp.net  Mon Aug 30 17:57:44 2010
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Mon, 30 Aug 2010 13:57:44 -0400
Subject: [armedbear-cvs] r12908 - trunk/abcl/examples/pure-lisp-to-java
Message-ID: <E1Oq8c4-00050b-I6@common-lisp.net>

Author: vvoutilainen
Date: Mon Aug 30 13:57:43 2010
New Revision: 12908

Log:
Add an example for using a java class with CLASSPATH, invoking java
functions from lisp code and finding the java class automagically
as it's in CLASSPATH.


Added:
   trunk/abcl/examples/pure-lisp-to-java/
   trunk/abcl/examples/pure-lisp-to-java/Main.java   (contents, props changed)
   trunk/abcl/examples/pure-lisp-to-java/README
   trunk/abcl/examples/pure-lisp-to-java/lispfunctions.lisp   (contents, props changed)

Added: trunk/abcl/examples/pure-lisp-to-java/Main.java
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/pure-lisp-to-java/Main.java	Mon Aug 30 13:57:43 2010
@@ -0,0 +1,39 @@
+/*
+ * Main.java
+ *
+ * Copyright (C) 2008 Ville Voutilainen
+ * $Id$
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+ */
+
+import org.armedbear.lisp.*;
+
+public class Main
+{
+    /**
+     * This example creates an Interpreter instance, loads our
+     * lisp code from a file and then looks up a function defined
+     * in the loaded lisp file and executes the function. 
+     *
+     * The function takes a single parameter and invokes a java method
+     * on the object provided. We provide our Main object as the parameter.
+     *
+     */
+    public static int addTwoNumbers(int a, int b)
+    {
+	return a + b;
+    }
+}

Added: trunk/abcl/examples/pure-lisp-to-java/README
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/pure-lisp-to-java/README	Mon Aug 30 13:57:43 2010
@@ -0,0 +1,38 @@
+ABCL Examples Building and Running Instructions
+===============================================
+
+To compile 
+
+    cmd$ javac  -cp ../../dist/abcl.jar  Main.java
+
+where the "../../../dist/abcl.jar" represents the path to your
+abcl.jar file, which is built via the Ant based build.  This path
+could be slightly different depending on how the system was
+constructed, and possibly due to operating system conventions for
+specifying relative paths.  However you resolve this locally, we'll
+refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these
+instructions.
+
+This compiles the Java source file "Main.java" into a JVM runtime or
+class file named "Main.class".
+
+To run the example (Main.class for example) from a Unix-like OS use:
+
+    cmd$ export CLASSPATH=.
+    cmd$ $ABCL_ROOT/abcl
+
+then, in abcl repl, use:
+(load "lispfunctions")
+(void-function)
+
+or in Windows use:
+
+    cmd$  set CLASSPATH=.
+    cmd$  $ABCL_ROOT/abcl
+
+then, in abcl repl, use:
+(load "lispfunctions")
+(void-function)
+
+This will result in the Main class being found from the CLASSPATH, and you
+can invoke the functions of the Main class from lisp code.

Added: trunk/abcl/examples/pure-lisp-to-java/lispfunctions.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/examples/pure-lisp-to-java/lispfunctions.lisp	Mon Aug 30 13:57:43 2010
@@ -0,0 +1,34 @@
+;;; lispfunctions.lisp
+;;;
+;;; Copyright (C) 2008 Ville Voutilainen
+;;; $Id$
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+; we need to get the
+; 1) class (Main)
+; 2) classes of the parameters (int)
+; 3) method reference (getting that requires the class
+; of our object and the classes of the parameters
+
+; After that we can invoke the function with jcall,
+; giving the method reference, the object and the parameters.
+; The result is a lisp object (no need to do jobject-lisp-value), 
+; unless we invoke the method
+; with jcall-raw. 
+(defun void-function ()
+  (let* ((result (jstatic "addTwoNumbers" "Main" 2 4)))
+    (format t "in void-function, result of calling addTwoNumbers(2, 4): ~a~%" result)))
+



From vvoutilainen at common-lisp.net  Mon Aug 30 18:03:37 2010
From: vvoutilainen at common-lisp.net (Ville Voutilainen)
Date: Mon, 30 Aug 2010 14:03:37 -0400
Subject: [armedbear-cvs] r12909 - trunk/abcl/examples/pure-lisp-to-java
Message-ID: <E1Oq8hl-00062n-NA@common-lisp.net>

Author: vvoutilainen
Date: Mon Aug 30 14:03:37 2010
New Revision: 12909

Log:
Correct the comments in the example.


Modified:
   trunk/abcl/examples/pure-lisp-to-java/lispfunctions.lisp

Modified: trunk/abcl/examples/pure-lisp-to-java/lispfunctions.lisp
==============================================================================
--- trunk/abcl/examples/pure-lisp-to-java/lispfunctions.lisp	(original)
+++ trunk/abcl/examples/pure-lisp-to-java/lispfunctions.lisp	Mon Aug 30 14:03:37 2010
@@ -17,17 +17,10 @@
 ;;; along with this program; if not, write to the Free Software
 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 
-; we need to get the
-; 1) class (Main)
-; 2) classes of the parameters (int)
-; 3) method reference (getting that requires the class
-; of our object and the classes of the parameters
-
-; After that we can invoke the function with jcall,
-; giving the method reference, the object and the parameters.
-; The result is a lisp object (no need to do jobject-lisp-value), 
-; unless we invoke the method
-; with jcall-raw. 
+; When the java class is in CLASSPATH, we can invoke its functions with
+; for example jstatic. In this example the Main class is to be found
+; in CLASSPATH, so we can just use it without having to load it
+; separately.
 (defun void-function ()
   (let* ((result (jstatic "addTwoNumbers" "Main" 2 4)))
     (format t "in void-function, result of calling addTwoNumbers(2, 4): ~a~%" result)))