carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-11-04 01:25:04 +03:00
Code Issues Projects Releases Wiki Activity

fix: allow dynamic closures to mutate the global env (#1184)

Browse Source
This commit is contained in:
Scott Olsen 2021-03-09 17:30:49 -05:00 committed by GitHub
parent 3ab7e229ae
commit 816eb65474
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 26 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
src/Eval.hs
View File

@ -242,8 +242,8 @@ eval ctx xobj@(XObj o info ty) preference resolver =
let newGlobals = (contextGlobalEnv newCtx) <> (contextGlobalEnv c) let newGlobals = (contextGlobalEnv newCtx) <> (contextGlobalEnv c)
newTypes = TypeEnv $ (getTypeEnv (contextTypeEnv newCtx)) <> (getTypeEnv (contextTypeEnv c)) newTypes = TypeEnv $ (getTypeEnv (contextTypeEnv newCtx)) <> (getTypeEnv (contextTypeEnv c))
updater = replaceHistory' (contextHistory ctx) . replaceGlobalEnv' newGlobals . replaceTypeEnv' newTypes updater = replaceHistory' (contextHistory ctx) . replaceGlobalEnv' newGlobals . replaceTypeEnv' newTypes
(_, res) <- apply (updater c) body params okArgs (ctx', res) <- apply (updater c) body params okArgs
pure (newCtx, res) pure (replaceGlobalEnv newCtx (contextGlobalEnv ctx'), res)
Left err -> pure (newCtx, Left err) Left err -> pure (newCtx, Left err)
XObj (Lst [XObj Dynamic _ _, sym, XObj (Arr params) _ _, body]) i _ : args -> XObj (Lst [XObj Dynamic _ _, sym, XObj (Arr params) _ _, body]) i _ : args ->
case checkArity (getName sym) params args of case checkArity (getName sym) params args of
@ -267,37 +267,37 @@ eval ctx xobj@(XObj o info ty) preference resolver =
Left _ -> pure (ctx, res) Left _ -> pure (ctx, res)
[XObj (Lst [XObj (Command (NullaryCommandFunction nullary)) _ _, _, _]) _ _] -> [XObj (Lst [XObj (Command (NullaryCommandFunction nullary)) _ _, _, _]) _ _] ->
do do
(_, evaledArgs) <- foldlM successiveEval (ctx, Right []) [] (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) []
case evaledArgs of case evaledArgs of
Right [] -> nullary ctx Right [] -> nullary c
Right _ -> error "eval nullary" Right _ -> error "eval nullary"
Left err -> pure (ctx, Left err) Left err -> pure (ctx, Left err)
[XObj (Lst [XObj (Command (UnaryCommandFunction unary)) _ _, _, _]) _ _, x] -> [XObj (Lst [XObj (Command (UnaryCommandFunction unary)) _ _, _, _]) _ _, x] ->
do do
(_, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x] (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x]
case evaledArgs of case evaledArgs of
Right [x'] -> unary ctx x' Right [x'] -> unary c x'
Right _ -> error "eval unary" Right _ -> error "eval unary"
Left err -> pure (ctx, Left err) Left err -> pure (ctx, Left err)
[XObj (Lst [XObj (Command (BinaryCommandFunction binary)) _ _, _, _]) _ _, x, y] -> [XObj (Lst [XObj (Command (BinaryCommandFunction binary)) _ _, _, _]) _ _, x, y] ->
do do
(_, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y] (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y]
case evaledArgs of case evaledArgs of
Right [x', y'] -> binary ctx x' y' Right [x', y'] -> binary c x' y'
Right _ -> error "eval binary" Right _ -> error "eval binary"
Left err -> pure (ctx, Left err) Left err -> pure (ctx, Left err)
[XObj (Lst [XObj (Command (TernaryCommandFunction ternary)) _ _, _, _]) _ _, x, y, z] -> [XObj (Lst [XObj (Command (TernaryCommandFunction ternary)) _ _, _, _]) _ _, x, y, z] ->
do do
(_, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y, z] (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y, z]
case evaledArgs of 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" Right _ -> error "eval ternary"
Left err -> pure (ctx, Left err) Left err -> pure (ctx, Left err)
XObj (Lst [XObj (Command (VariadicCommandFunction variadic)) _ _, _, _]) _ _ : args -> XObj (Lst [XObj (Command (VariadicCommandFunction variadic)) _ _, _, _]) _ _ : args ->
do do
(_, evaledArgs) <- foldlM successiveEval (ctx, Right []) args (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
case evaledArgs of case evaledArgs of
Right xs -> variadic ctx xs Right xs -> variadic c xs
Left err -> pure (ctx, Left err) Left err -> pure (ctx, Left err)
XObj (Lst [XObj (Command _) _ _, sym, XObj (Arr params) _ _]) i _ : args -> XObj (Lst [XObj (Command _) _ _, sym, XObj (Arr params) _ _]) i _ : args ->
badArity (getName sym) params args i badArity (getName sym) params args i

14
test/dynamic-closures.carp
View File

@ -2,6 +2,7 @@
(use Test) (use Test)
(defdynamic x 400) (defdynamic x 400)
(defdynamic z 0)
;; close over a global variable ;; close over a global variable
(defdynamic closure-one (defdynamic closure-one
@ -23,6 +24,10 @@
(defdynamic closure-five (defdynamic closure-five
(fn [] (let [x 5] (fn [] x)))) (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) (defdynamic y 500)
(defmacro test-closure-one [] (closure-one)) (defmacro test-closure-one [] (closure-one))
@ -30,6 +35,11 @@
(defmacro test-closure-three [] (closure-three)) (defmacro test-closure-three [] (closure-three))
(defmacro test-closure-four [] (closure-four)) (defmacro test-closure-four [] (closure-four))
(defmacro test-closure-five [] ((closure-five))) (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) ;; Change the global value of x (closed over in closure-one)
(set! x 1000) (set! x 1000)
@ -55,4 +65,8 @@
5 5
(test-closure-five) (test-closure-five)
"nested closures prefer closed-over bindings") "nested closures prefer closed-over bindings")
(assert-equal test
3
(test-closure-six)
"closures can update the global environment")
) )