From 816eb65474d01b1ae4b42af1c63d4b485c6f89cd Mon Sep 17 00:00:00 2001
From: Scott Olsen <scg.olsen@gmail.com>
Date: Tue, 9 Mar 2021 17:30:49 -0500
Subject: [PATCH] fix: allow dynamic closures to mutate the global env (#1184)

---
 src/Eval.hs                | 24 ++++++++++++------------
 test/dynamic-closures.carp | 14 ++++++++++++++
 2 files changed, 26 insertions(+), 12 deletions(-)

diff --git a/src/Eval.hs b/src/Eval.hs
index 4eb1d1af..7f4140d2 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -242,8 +242,8 @@ eval ctx xobj@(XObj o info ty) preference resolver =
                     let newGlobals = (contextGlobalEnv newCtx) <> (contextGlobalEnv c)
                         newTypes = TypeEnv $ (getTypeEnv (contextTypeEnv newCtx)) <> (getTypeEnv (contextTypeEnv c))
                         updater = replaceHistory' (contextHistory ctx) . replaceGlobalEnv' newGlobals . replaceTypeEnv' newTypes
-                    (_, res) <- apply (updater c) body params okArgs
-                    pure (newCtx, res)
+                    (ctx', res) <- apply (updater c) body params okArgs
+                    pure (replaceGlobalEnv newCtx (contextGlobalEnv ctx'), res)
                   Left err -> pure (newCtx, Left err)
         XObj (Lst [XObj Dynamic _ _, sym, XObj (Arr params) _ _, body]) i _ : args ->
           case checkArity (getName sym) params args of
@@ -267,37 +267,37 @@ eval ctx xobj@(XObj o info ty) preference resolver =
                 Left _ -> pure (ctx, res)
         [XObj (Lst [XObj (Command (NullaryCommandFunction nullary)) _ _, _, _]) _ _] ->
           do
-            (_, evaledArgs) <- foldlM successiveEval (ctx, Right []) []
+            (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) []
             case evaledArgs of
-              Right [] -> nullary ctx
+              Right [] -> nullary c
               Right _ -> error "eval nullary"
               Left err -> pure (ctx, Left err)
         [XObj (Lst [XObj (Command (UnaryCommandFunction unary)) _ _, _, _]) _ _, x] ->
           do
-            (_, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x]
+            (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x]
             case evaledArgs of
-              Right [x'] -> unary ctx x'
+              Right [x'] -> unary c x'
               Right _ -> error "eval unary"
               Left err -> pure (ctx, Left err)
         [XObj (Lst [XObj (Command (BinaryCommandFunction binary)) _ _, _, _]) _ _, x, y] ->
           do
-            (_, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y]
+            (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y]
             case evaledArgs of
-              Right [x', y'] -> binary ctx x' y'
+              Right [x', y'] -> binary c x' y'
               Right _ -> error "eval binary"
               Left err -> pure (ctx, Left err)
         [XObj (Lst [XObj (Command (TernaryCommandFunction ternary)) _ _, _, _]) _ _, x, y, z] ->
           do
-            (_, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y, z]
+            (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y, z]
             case evaledArgs of
-              Right [x', y', z'] -> ternary ctx x' y' z'
+              Right [x', y', z'] -> ternary c x' y' z'
               Right _ -> error "eval ternary"
               Left err -> pure (ctx, Left err)
         XObj (Lst [XObj (Command (VariadicCommandFunction variadic)) _ _, _, _]) _ _ : args ->
           do
-            (_, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
+            (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
             case evaledArgs of
-              Right xs -> variadic ctx xs
+              Right xs -> variadic c xs
               Left err -> pure (ctx, Left err)
         XObj (Lst [XObj (Command _) _ _, sym, XObj (Arr params) _ _]) i _ : args ->
           badArity (getName sym) params args i
diff --git a/test/dynamic-closures.carp b/test/dynamic-closures.carp
index 5278d9fb..bf4ac7ce 100644
--- a/test/dynamic-closures.carp
+++ b/test/dynamic-closures.carp
@@ -2,6 +2,7 @@
 (use Test)
 
 (defdynamic x 400)
+(defdynamic z 0)
 
 ;; close over a global variable
 (defdynamic closure-one
@@ -23,6 +24,10 @@
 (defdynamic closure-five
   (fn [] (let [x 5] (fn [] x))))
 
+;; closures can update the global environment (issue #1181)
+(defdynamic closure-six
+  (fn [] (set! z (inc z))))
+
 (defdynamic y 500)
 
 (defmacro test-closure-one [] (closure-one))
@@ -30,6 +35,11 @@
 (defmacro test-closure-three [] (closure-three))
 (defmacro test-closure-four [] (closure-four))
 (defmacro test-closure-five [] ((closure-five)))
+(defmacro test-closure-six []
+  (do (closure-six)
+      (closure-six)
+      (closure-six)
+      z))
 
 ;; Change the global value of x (closed over in closure-one)
 (set! x 1000)
@@ -55,4 +65,8 @@
     5
     (test-closure-five)
     "nested closures prefer closed-over bindings")
+  (assert-equal test
+    3
+    (test-closure-six)
+    "closures can update the global environment")
 )