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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Apr 25 10:19:51 2009
New Revision: 11783

Log:
Fix fasl reader special bindings leak.

* Bind the *FASL-ANONYMOUS-PACKAGE* to the outer most scope
  which needs one, instead of binding it upon first use.
  Specials shouldn't be bound with indefinite extent:
  some other code might limit the extent by unbinding its specials.

Modified:
   trunk/abcl/src/org/armedbear/lisp/FaslReader.java
   trunk/abcl/src/org/armedbear/lisp/Load.java
   trunk/abcl/src/org/armedbear/lisp/Primitives.java
   trunk/abcl/src/org/armedbear/lisp/Stream.java
   trunk/abcl/src/org/armedbear/lisp/compile-file.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/FaslReader.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/FaslReader.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/FaslReader.java	Sat Apr 25 10:19:51 2009
@@ -284,10 +284,7 @@
             LispThread thread = LispThread.currentThread();
             Symbol symbol = (Symbol) stream.readSymbol(FaslReadtable.getInstance());
             LispObject pkg = Load._FASL_ANONYMOUS_PACKAGE_.symbolValue(thread);
-            if (pkg == NIL) {
-                thread.bindSpecial(Load._FASL_ANONYMOUS_PACKAGE_,
-                                   pkg = new Package());
-            }
+            Debug.assertTrue(pkg != NIL);
             symbol = ((Package)pkg).intern(symbol.getName());
             symbol.setPackage(NIL);
             return symbol;

Modified: trunk/abcl/src/org/armedbear/lisp/Load.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Load.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Load.java	Sat Apr 25 10:19:51 2009
@@ -344,6 +344,11 @@
 
     // ### *fasl-anonymous-package*
     // internal symbol
+    /**
+     * This variable gets bound to a package with no name in which the
+     * reader can intern its uninterned symbols.
+     * 
+     */
     public static final Symbol _FASL_ANONYMOUS_PACKAGE_ =
         internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL);
 
@@ -473,11 +478,18 @@
     {
         Stream in = (Stream) _LOAD_STREAM_.symbolValue(thread);
         final Environment env = new Environment();
-        while (true) {
-            LispObject obj = in.faslRead(false, EOF, true, thread);
-            if (obj == EOF)
-                break;
-            eval(obj, env, thread);
+        final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding;
+        try {
+            thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package());
+            while (true) {
+                LispObject obj = in.faslRead(false, EOF, true, thread);
+                if (obj == EOF)
+                    break;
+                eval(obj, env, thread);
+            }
+        }
+        finally {
+            thread.lastSpecialBinding = lastSpecialBinding;
         }
         return T;
     }

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	Sat Apr 25 10:19:51 2009
@@ -3017,6 +3017,20 @@
   private static final Primitive _MAKE_PACKAGE =
     new Primitive("%make-package", PACKAGE_SYS, false)
     {
+      /**
+       * This invocation is solely used to be able to create
+       * a package to bind to *FASL-ANONYMOUS-PACKAGE*
+       */
+      @Override
+      public LispObject execute()
+        throws ConditionThrowable
+      {
+        return new Package();
+      }
+
+      /**
+       * This invocation is used by MAKE-PACKAGE to create a package
+       */
       @Override
       public LispObject execute(LispObject first, LispObject second,
                                 LispObject third)

Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Stream.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Stream.java	Sat Apr 25 10:19:51 2009
@@ -518,8 +518,16 @@
       }
     else
       {
+        SpecialBinding lastSpecialBinding = thread.lastSpecialBinding;
         thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL);
-        return faslReadPreservingWhitespace(eofError, eofValue, true, thread);
+        try
+          {
+            return faslReadPreservingWhitespace(eofError, eofValue, true, thread);
+          }
+        finally
+          {
+            thread.lastSpecialBinding = lastSpecialBinding;
+          }
       }
   }
 

Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Sat Apr 25 10:19:51 2009
@@ -427,7 +427,8 @@
                   (*debug* *debug*)
                   (*explain* *explain*)
                   (jvm::*functions-defined-in-current-file* '())
-                  (*fbound-names* '()))
+                  (*fbound-names* '())
+                  (*fasl-anonymous-package* (%make-package)))
               (jvm::with-file-compilation
                 (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
                 (%stream-terpri out)

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	Sat Apr 25 10:19:51 2009
@@ -5019,7 +5019,8 @@
 	       pathname class-file lambda-list
 	       (set-compiland-and-write-class-file class-file compiland)
 	       (setf (local-function-class-file local-function) class-file)
-	       (setf (local-function-function local-function) (load-compiled-function pathname))
+	       (setf (local-function-function local-function)
+                     (load-compiled-function pathname))
 	       (when (local-function-variable local-function)
 		 (let ((g (declare-object (load-compiled-function pathname))))
 		   (emit-make-compiled-closure-for-flet/labels 

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	Sat Apr 25 10:19:51 2009
@@ -413,7 +413,8 @@
 
 (defun compile (name &optional definition)
   (let ((*file-compilation* nil)
-        (*pathnames-generator* #'make-temp-file))
+        (*pathnames-generator* #'make-temp-file)
+        (sys::*fasl-anonymous-package* (sys::%make-package)))
     (jvm-compile name definition)))
 
 (defmacro with-file-compilation (&body body)