[armedbear-cvs] r12866 - in branches/generic-class-file/abcl: src/org/armedbear/lisp test/lisp/abcl

[Alessio Stalla]

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