[armedbear-cvs] r13484 - trunk/abcl/src/org/armedbear/lisp

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Sat Aug 13 01:29:08 2011
New Revision: 13484

Log:
Store local functions in the parent compiland, since you can't
reach the function from the compiland, but the other way around works.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Fri Aug 12 23:46:15 2011	(r13483)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Sat Aug 13 01:29:08 2011	(r13484)
@@ -884,7 +884,7 @@
          (lambda-list (cadr definition))
          (compiland (make-compiland :name name :parent *current-compiland*))
          (local-function (make-local-function :name name :compiland compiland)))
-    (push compiland (compiland-children *current-compiland*))
+    (push local-function (compiland-children *current-compiland*))
     (when variable-name
       (setf (local-function-variable local-function)
             (make-variable :name variable-name)))
@@ -1003,8 +1003,9 @@
                   (compiland (make-compiland :name (if named-lambda-p
                                                        name (gensym "ANONYMOUS-LAMBDA-"))
                                              :lambda-expression lambda-form
-                                             :parent *current-compiland*)))
-             (push compiland (compiland-children *current-compiland*))
+                                             :parent *current-compiland*))
+                  (local-function (make-local-function :compiland compiland)))
+             (push local-function (compiland-children *current-compiland*))
              (multiple-value-bind (body decls)
                  (parse-body body)
                (setf (compiland-lambda-expression compiland)
@@ -1014,7 +1015,7 @@
                (let ((*visible-variables* *visible-variables*)
                      (*current-compiland* compiland))
                  (p1-compiland compiland)))
-             (list 'FUNCTION compiland)))
+             (list 'FUNCTION local-function)))
           ((setf local-function (find-local-function (cadr form)))
            (dformat "p1-function local function ~S~%" (cadr form))
            ;;we found out that the function needs a reference

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 12 23:46:15 2011	(r13483)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Aug 13 01:29:08 2011	(r13484)
@@ -4140,37 +4140,35 @@
     (let ((*blocks* (cons block *blocks*)))
       (compile-progn-body body target representation))))
 
-(defun p2-lambda (compiland target)
-  (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 :compiland compiland))
-                         +lisp-object+))
-        (t
-         (with-open-stream (stream (sys::%make-byte-array-output-stream))
-           (compile-and-write-to-stream compiland stream)
-           (let ((bytes (sys::%get-output-stream-bytes stream)))
-             (sys::put-memory-function *memory-class-loader*
-                                       (class-name-internal
-                                        (abcl-class-file-class-name
-                                         (compiland-class-file compiland)))
-                  bytes)
-             (emit-getstatic *this-class*
-                         (declare-local-function
-                          (make-local-function
-                           :compiland compiland))
-                         +lisp-object+)))))
-  (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+))
+(defun p2-lambda (local-function target)
+  (let ((compiland (local-function-compiland local-function)))
+    (aver (null (compiland-class-file compiland)))
+    (cond (*file-compilation*
+           (compile-and-write-to-stream compiland)
+           (emit-getstatic *this-class*
+                           (declare-local-function local-function)
+                           +lisp-object+))
+          (t
+           (with-open-stream (stream (sys::%make-byte-array-output-stream))
+             (compile-and-write-to-stream compiland stream)
+             (let ((bytes (sys::%get-output-stream-bytes stream)))
+               (sys::put-memory-function *memory-class-loader*
+                                         (class-name-internal
+                                          (abcl-class-file-class-name
+                                           (compiland-class-file compiland)))
+                                         bytes)
+               (emit-getstatic *this-class*
+                               (declare-local-function local-function)
+                               +lisp-object+)))))
+    (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.
+          (t
+           (aver nil)))) ;; Shouldn't happen.
 
   (emit-move-from-stack target))
 
@@ -4250,7 +4248,7 @@
                               "getSymbolSetfFunctionOrDie"
                               nil +lisp-object+)
           (emit-move-from-stack target))))
-      ((compiland-p name)
+      ((local-function-p name)
        (dformat t "p2-function case 3~%")
        (p2-lambda name target))
       (t

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Fri Aug 12 23:46:15 2011	(r13483)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Sat Aug 13 01:29:08 2011	(r13484)
@@ -199,7 +199,7 @@
   arity             ; number of args, or NIL if the number of args can vary.
   p1-result         ; the parse tree as created in pass 1
   parent            ; the parent for compilands which defined within another
-  children          ; List of local compilands
+  children          ; List of local functions
                     ; defined with FLET, LABELS or LAMBDA
   blocks            ; TAGBODY, PROGV, BLOCK, etc. blocks
   argument-register