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

[Erik Huelsmann]

Author: ehuelsmann
Date: Fri May 22 14:04:53 2009
New Revision: 11926

Log:
Compilation of functions with a non-null
lexical environment part 2 [of 2]: Functions.


Modified:
   trunk/abcl/src/org/armedbear/lisp/Environment.java
   trunk/abcl/src/org/armedbear/lisp/Primitives.java
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Environment.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Environment.java	Fri May 22 14:04:53 2009
@@ -347,4 +347,20 @@
             return result.nreverse();
       }
     };
+
+  // ### environment-all-functions
+  private static final Primitive ENVIRONMENT_ALL_FUNS =
+    new Primitive("environment-all-functions", PACKAGE_SYS, true, "environment")
+    {
+      @Override
+      public LispObject execute(LispObject arg) throws ConditionThrowable
+      {
+            Environment env = checkEnvironment(arg);
+            LispObject result = NIL;
+            for (FunctionBinding binding = env.lastFunctionBinding;
+                 binding != null; binding = binding.next)
+            result = result.push(new Cons(binding.name, binding.value));
+            return result.nreverse();
+      }
+    };
 }

Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java	Fri May 22 14:04:53 2009
@@ -1787,6 +1787,18 @@
       }
     };
 
+  // ### macro-function-p
+  private static final Primitive MACRO_FUNCTION_P =
+      new Primitive("macro-function-p", PACKAGE_SYS, true, "value")
+  {
+      @Override
+      public LispObject execute(LispObject arg) throws ConditionThrowable
+      {
+          return (arg instanceof MacroObject) ? T : NIL;
+      }
+  };
+
+
   // ### make-symbol-macro
   private static final Primitive MAKE_SYMBOL_MACRO =
       new Primitive("make-symbol-macro", PACKAGE_SYS, true, "expansion")

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri May 22 14:04:53 2009
@@ -3028,6 +3028,20 @@
            (compile-var-ref (make-var-ref
                              (local-function-variable local-function))
                             'stack nil))
+          ((local-function-environment local-function)
+           (assert (local-function-references-allowed-p local-function))
+           (assert (not *file-compilation*))
+           (emit 'getstatic *this-class*
+                 (declare-object (local-function-environment local-function)
+                                 +lisp-environment+
+                                 +lisp-environment-class+)
+                 +lisp-environment+)
+           (emit 'getstatic *this-class*
+                 (declare-object (local-function-name local-function))
+                 +lisp-object+)
+           (emit-invokevirtual +lisp-environment-class+ "lookupFunction"
+                               (list +lisp-object+)
+                               +lisp-object+))
           (t
            (dformat t "compile-local-function-call default case~%")
            (let* ((g (if *file-compilation*
@@ -8240,7 +8254,7 @@
   (let ((*all-variables* nil)
         (*closure-variables* nil)
         (*undefined-variables* nil)
-        (*local-functions* nil)
+        (*local-functions* *local-functions*)
         (*current-compiland* compiland))
     (with-saved-compiler-policy
       ;; Pass 1.
@@ -8417,6 +8431,7 @@
         (expression definition)
         (*file-compilation* nil)
         (*visible-variables* nil)
+        (*local-functions* nil)
         (*pathnames-generator* #'make-temp-file)
         (sys::*fasl-anonymous-package* (sys::%make-package))
         environment)
@@ -8441,6 +8456,13 @@
                              :references-allowed-p
                              (not (sys:symbol-macro-p (cdr var)))
                              :compiland NIL) *visible-variables*)))
+    (when environment
+      (dolist (fun (reverse (environment-all-functions environment)))
+        (push (make-local-function :name (car fun)
+                                   :references-allowed-p
+                                   (not (macro-function-p (cdr fun)))
+                                   :environment environment)
+              *local-functions*)))
     ;; FIXME: we still need to add local functions, ofcourse.
     (handler-bind
         ((compiler-unsupported-feature-error

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Fri May 22 14:04:53 2009
@@ -337,10 +337,14 @@
   name
   compiland
   inline-expansion
-  function  ;; the function loaded through load-compiled-function
-  class-file
-  variable  ;; the variable which contains the loaded compiled function
-            ;; or compiled closure
+  function    ;; the function loaded through load-compiled-function
+  class-file  ;; the class file structure for this function
+  variable    ;; the variable which contains the loaded compiled function
+              ;; or compiled closure
+  environment ;; the environment in which the function is stored in
+              ;; case of a function from an enclosing lexical environment
+              ;; which itself isn't being compiled
+  (references-allowed-p t)
   )
 
 (defvar *local-functions* ())