[armedbear-cvs] r12840 - branches/generic-class-file/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Jul 31 17:33:24 2010
New Revision: 12840

Log:
Introduce "dual mode" operation for emit-invoke* and emit-*static,
in order to allow test-writing.

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	Sat Jul 31 17:33:24 2010
@@ -463,7 +463,10 @@
          (descriptor (car info))
          (stack-effect (cdr info))
          (class-name (!class-name class-name))
-         (index (pool-method class-name method-name descriptor))
+         (index (if (null *current-code-attribute*)
+                    (pool-method class-name method-name descriptor)
+                    (pool-add-method-ref *pool* class-name
+                                         method-name descriptor)))
          (instruction (apply #'%emit 'invokestatic (u2 index))))
     (setf (instruction-stack instruction) stack-effect)))
 
@@ -486,7 +489,10 @@
          (descriptor (car info))
          (stack-effect (cdr info))
          (class-name (!class-name class-name))
-         (index (pool-method class-name method-name descriptor))
+         (index (if (null *current-code-attribute*)
+                    (pool-method class-name method-name descriptor)
+                    (pool-add-method-ref *pool* class-name
+                                         method-name descriptor)))
          (instruction (apply #'%emit 'invokevirtual (u2 index))))
     (declare (type (signed-byte 8) stack-effect))
     (let ((explain *explain*))
@@ -505,7 +511,10 @@
          (descriptor (car info))
          (stack-effect (cdr info))
          (class-name (!class-name class-name))
-         (index (pool-method class-name "<init>" descriptor))
+         (index (if (null *current-code-attribute*)
+                    (pool-method class-name "<init>" descriptor)
+                    (pool-add-method-ref *pool* class-name
+                                         "<init>" descriptor)))
          (instruction (apply #'%emit 'invokespecial (u2 index))))
     (declare (type (signed-byte 8) stack-effect))
     (setf (instruction-stack instruction) (1- stack-effect))))
@@ -544,14 +553,18 @@
 (declaim (inline emit-getstatic emit-putstatic))
 (defknown emit-getstatic (t t t) t)
 (defun emit-getstatic (class-name field-name type)
-  (let ((index (pool-field (!class-name class-name)
-                           field-name (!class-ref type))))
+  (let ((index (if (null *current-code-attribute*)
+                   (pool-field (!class-name 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 (pool-field (!class-name class-name)
-                           field-name (!class-ref type))))
+  (let ((index (if (null *current-code-attribute*)
+                   (pool-field (!class-name class-name)
+                           field-name (!class-ref type))
+                   (pool-add-field-ref *pool* class-name field-name type))))
     (apply #'%emit 'putstatic (u2 index))))
 
 (defvar type-representations '((:int fixnum)

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	Sat Jul 31 17:33:24 2010
@@ -875,7 +875,7 @@
   )
 
 
-(defvar *current-code-attribute*)
+(defvar *current-code-attribute* nil)
 
 (defun save-code-specials (code)
   (setf (code-code code) *code*
@@ -889,7 +889,7 @@
         *registers-allocated* (code-max-locals code)
         *register* (code-current-local code)))
 
-(defmacro with-code-to-method ((method &key safe-nesting) &body body)
+(defmacro with-code-to-method ((class-file method &key safe-nesting) &body body)
   (let ((m (gensym))
         (c (gensym)))
     `(progn
@@ -898,6 +898,7 @@
                (save-code-specials *current-code-attribute*))))
        (let* ((,m ,method)
               (,c (method-ensure-code method))
+              (*pool* (class-file-constants ,class-file))
               (*code* (code-code ,c))
               (*registers-allocated* (code-max-locals ,c))
               (*register* (code-current-local ,c))