Changeset 12866

Timestamp:

08/06/10 21:47:06 (13 years ago)

Author:

astalla

Message:

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

Location:

branches/generic-class-file/abcl

Files:

• src/org/armedbear/lisp/jvm-class-file.lisp (modified) (4 diffs)
• test/lisp/abcl/class-file.lisp (modified) (1 diff)

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

@@ -882 +882 @@
   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
 
 
@@ -1047 +1047 @@
         *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)))
@@ -1055 +1056 @@
                (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))
@@ -1063 +1064 @@
          ,@body
          (setf (code-code ,c) *code*
+         (code-current-local ,c) *register*
 ;;               (code-exception-handlers ,c) *handlers*
                (code-max-locals ,c) *registers-allocated*))

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

@@ -319 +319 @@
           (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,