mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
fix: allow dynamic closures to mutate the global env (#1184)
This commit is contained in:
parent
3ab7e229ae
commit
816eb65474
24
src/Eval.hs
24
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
|
||||
|
@ -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")
|
||||
)
|
||||
|
Loading…
Reference in New Issue
Block a user