Changeset 8349 for trunk/j/src/org/armedbear/lisp/jvm.lisp

Timestamp:

01/13/05 11:19:37 (17 years ago)

Author:

piso

Message:

Work in progress (tested).

File:

• trunk/j/src/org/armedbear/lisp/jvm.lisp (modified) (9 diffs)

trunk/j/src/org/armedbear/lisp/jvm.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003-2005 Peter Graves
-;;; $Id: jvm.lisp,v 1.347 2005-01-13 10:09:20 piso Exp $
+;;; $Id: jvm.lisp,v 1.348 2005-01-13 11:19:37 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -144 +144 @@
           (dump-1-variable variable))
         (%format t "  None.~%"))))
-
-(defvar *nesting-level* 0)
 
 (defstruct variable
@@ -449 +447 @@
                 `(lambda ,lambda-list ,@decls (block ,name ,@body)))
           (let ((*visible-variables* *visible-variables*)
-                (*nesting-level* (1+ *nesting-level*))
                 (*current-compiland* compiland))
             (p1-compiland compiland)))
@@ -484 +481 @@
     (dolist (local-function local-functions)
       (let ((*visible-variables* *visible-variables*)
-            (*nesting-level* (1+ *nesting-level*))
             (*current-compiland* (local-function-compiland local-function)))
         (p1-compiland (local-function-compiland local-function))))
@@ -506 +502 @@
               `(lambda ,lambda-list ,@decls (block nil ,@body)))
         (let ((*visible-variables* *visible-variables*)
-              (*nesting-level* (1+ *nesting-level*))
               (*current-compiland* compiland))
           (p1-compiland compiland)))
@@ -3956 +3951 @@
                    (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
     (setf form (compiland-lambda-expression compiland))
-    (let ((*nesting-level* (1+ *nesting-level*)))
-      (setf classfile (if *compile-file-truename*
-                          (sys::next-classfile-name)
-                          (prog1
-                           (%format nil "local-~D.class" *child-count*)
-                           (incf *child-count*))))
-      (setf (compiland-classfile compiland) classfile)
-      (let ((*current-compiland* compiland)
-            (*speed* *speed*)
-            (*safety* *safety*)
-            (*debug* *debug*))
-        (p2-compiland compiland))
-      (when (null *compile-file-truename*)
-        (setf function (sys:load-compiled-function classfile))))
+    (setf classfile (if *compile-file-truename*
+                        (sys::next-classfile-name)
+                        (prog1
+                         (%format nil "local-~D.class" *child-count*)
+                         (incf *child-count*))))
+    (setf (compiland-classfile compiland) classfile)
+    (let ((*current-compiland* compiland)
+          (*speed* *speed*)
+          (*safety* *safety*)
+          (*debug* *debug*))
+      (p2-compiland compiland))
+    (when (null *compile-file-truename*)
+      (setf function (sys:load-compiled-function classfile)))
     (cond (local-function
            (setf (local-function-classfile local-function) classfile)
@@ -4113 +4107 @@
       (cond
        ((setf local-function (find-local-function name))
+        (when (eq (local-function-compiland local-function) *current-compiland*)
+          (emit 'aload 0) ; this
+          (emit-move-from-stack target)
+          (return-from p2-function))
         (if (local-function-variable local-function)
             (emit 'var-ref (local-function-variable local-function) :stack)
@@ -4122 +4120 @@
                     g
                     +lisp-object+))) ; Stack: template-function
-;;         (unless (zerop *nesting-level*)
-;;           (error "nesting level > 0, not supported"))
         (cond
          ((null *closure-variables*)) ; Nothing to do.
@@ -5270 +5266 @@
     (dformat t "pass2 *using-arg-array* = ~S~%" *using-arg-array*)
     (dformat t "pass2 *child-p* = ~S~%" *child-p*)
-    (dformat t "pass2 *nesting-level* = ~S~%" *nesting-level*)
-;;     (when (zerop *nesting-level*)
-;;       (setf *child-count* 0))
-;;     (setf *context* (make-context))
     (setf (method-name-index execute-method)
           (pool-name (method-name execute-method)))