From: Richard M Kreuter <kreuter@users.sourceforge.net>
Date: Thu, 5 Feb 2009 18:27:31 +0000 (+0000)
Subject: 1.0.25.10: Fix package locks checks for local functions in the interpeter.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d2b9d8bbd2d1489723a4437e64f607585670ed58;p=sbcl.git

1.0.25.10: Fix package locks checks for local functions in the interpeter.

* Package lock checks were being performed in the function binding form's
  body's lexical environment, causing lossage for forms like

  (locally (declare (disable-package-locks foo:bar))
    (flet ((foo:bar ...))
      (declare (enable-package-locks foo:bar))
      ...))

  In particular, this broke some TRACE extensions.
---

diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp
index 0f04a0f..6f6a88f 100644
--- a/src/code/full-eval.lisp
+++ b/src/code/full-eval.lisp
@@ -185,13 +185,13 @@
 
 ;;; Augment ENV with a local function binding
 (declaim (inline push-fun))
-(defun push-fun (name value env)
+(defun push-fun (name value calling-env body-env)
   (when (fboundp name)
-    (let ((sb!c:*lexenv* (env-native-lexenv env)))
+    (let ((sb!c:*lexenv* (env-native-lexenv calling-env)))
       (program-assert-symbol-home-package-unlocked
        :eval name "binding ~A as a local function")))
-  (push (cons name value) (env-funs env))
-  (push (cons name :bogus) (sb!c::lexenv-funs (env-native-lexenv env))))
+  (push (cons name value) (env-funs body-env))
+  (push (cons name :bogus) (sb!c::lexenv-funs (env-native-lexenv body-env))))
 
 (sb!int:def!method print-object ((env env) stream)
   (print-unreadable-object (env stream :type t :identity t)))
@@ -682,6 +682,8 @@
           (push-fun (car function-def)
                     ;; Evaluate the function definitions in ENV.
                     (eval-local-function-def function-def env)
+                    ;; Do package-lock checks in ENV.
+                    env
                     ;; But add the bindings to the child environment.
                     new-env))
         (eval-progn body new-env)))))
@@ -698,6 +700,7 @@
         (dolist (function-def local-functions)
           (push-fun (car function-def)
                     (eval-local-function-def function-def env)
+                    old-env
                     env))
         ;; And then add an environment for the body of the LABELS.  A
         ;; separate environment from the one where we added the
diff --git a/tests/full-eval.impure.lisp b/tests/full-eval.impure.lisp
index 98f345f..032634f 100644
--- a/tests/full-eval.impure.lisp
+++ b/tests/full-eval.impure.lisp
@@ -55,3 +55,22 @@
           (assert (eql #c(1.0 2.0) (evaluated-struct-csingle *evaluated-struct*)))
           (assert (eql #c(2.0d0 3.0d0) (evaluated-struct-cdouble *evaluated-struct*))))))
 
+;;; Prior to 1.0.25, the interpreter checked for package lock
+;;; violation for a local function in the fbinding form's body's
+;;; lexical environment.
+(let ((sb-ext:*evaluator-mode* :interpret))
+  (assert
+   (ignore-errors
+     (eval
+      '(eql
+        (locally (declare (disable-package-locks
+                           ;; rather than create a whole new package
+                           ;; just to test this corner case, we'll
+                           ;; lexically shadow something innocuous in
+                           ;; the CL package.
+                           cl:ed))
+          (flet ((cl:ed ()
+                   42))
+            (declare (enable-package-locks cl:ed))
+            (cl:ed)))
+        42)))))