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

fix: support recursive let bindings in static code (Fix 402) (#1230)

Browse Source
This commit is contained in:
Scott Olsen 2021-06-05 11:45:50 -04:00 committed by GitHub
parent 8f055f287a
commit bda32d6104
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 65 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/Concretize.hs
View File

@ -140,6 +140,11 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
SymPath spath name = rootDefinitionPath
lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii) ++ "_env")
lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
-- Anonymous functions bound to a let name might call themselves. These recursive instances will have already been qualified as LookupRecursive symbols.
-- Rename the recursive calls according to the generated lambda name so that we can call these correctly from C.
renameRecursives (XObj (Sym _ LookupRecursive) si st) = (XObj (Sym lambdaPath LookupRecursive) si st)
renameRecursives x = x
recBody = walk renameRecursives okBody
environmentTypeName = pathToC lambdaPath ++ "_ty"
tyPath = (SymPath [] environmentTypeName)
extendedArgs =
@ -158,7 +163,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
)
ai
at
lambdaCallback = XObj (Lst [XObj (Defn (Just (Set.fromList capturedVars))) (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, okBody]) i t
lambdaCallback = XObj (Lst [XObj (Defn (Just (Set.fromList capturedVars))) (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, recBody]) i t
-- The lambda will also carry with it a special made struct containing the variables it captures
-- (if it captures at least one variable)
structMemberPairs =
@ -203,7 +208,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
modify (deleterDeps ++)
modify (copyFn :)
modify (copyDeps ++)
pure (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) fni fnt, args, okBody])
pure (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) fni fnt, args, recBody])
Left err ->
pure (Left err)
visitList _ Toplevel env (XObj (Lst [def@(XObj Def _ _), nameSymbol, body]) _ t) =

26
src/InitialTypes.hs
View File

@ -212,7 +212,26 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
[XObj (Defn _) _ _, XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj))
XObj defn@(Defn _) _ _ : _ ->
pure (Left (InvalidObjExample defn xobj "(defn <name> [<arguments>] <body>)"))
-- Fn
-- Anonymous function bound to a let name
-- Supports recursion by assigning the same type to recursive calls ("let-rec").
[XObj LocalDef _ _, XObj (Sym path _) si _, XObj (Lst [fn@(XObj (Fn _ _) _ _), XObj (Arr argList) argsi argst, body]) _ _] ->
do
(argTypes, returnType, funcScopeEnv) <- getTys env argList
lt <- genVarTy
let funcTy = Just (FuncTy argTypes returnType lt)
typedNameSymbol = XObj (Sym path LookupRecursive) si funcTy
Right envWithSelf = E.insertX funcScopeEnv path typedNameSymbol
visitedBody <- visit envWithSelf body
visitedArgs <- mapM (visit envWithSelf) argList
pure $ do
okBody <- visitedBody
okArgs <- sequence visitedArgs
let final = XObj (Lst [fn, XObj (Arr okArgs) argsi argst, okBody]) i funcTy
pure final --(trace ("FINAL: " ++ show final) final)
-- Let bindings
[XObj LocalDef _ _, _, value] ->
visit env value
-- Unbound anonymous Fn
[fn@(XObj (Fn _ _) _ _), XObj (Arr argList) argsi argst, body] ->
do
(argTypes, returnType, funcScopeEnv) <- getTys env argList
@ -427,6 +446,9 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
in -- Need to fold (rather than map) to make the previous bindings accessible to the later ones, i.e. (let [a 100 b a] ...)
foldM createBinderForLetPair (Right emptyInnerEnv) pairs
where
-- Cast binders to Local Defs so that we can account for recursion ("let-rec").
-- A local def carries the binder name along with its value, so we can appropriately type recursive uses.
-- e.g. (let [f (fn [x] (if (= x 1) x (f (dec x))))])
createBinderForLetPair :: Either TypeError Env -> (XObj, XObj) -> State Integer (Either TypeError Env)
createBinderForLetPair envOrErr (sym, expr) =
case envOrErr of
@ -435,7 +457,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
case xobjObj sym of
(Sym (SymPath _ name) _) ->
do
visited <- visit env' expr
visited <- visit env' (toLocalDef name expr)
pure
( join
(replaceLeft (InvalidLetBinding xobjs (sym, expr)) . E.insert env' (SymPath [] name) . Binder emptyMeta <$> visited)

7
src/Obj.hs
View File

@ -1121,3 +1121,10 @@ trueXObj = XObj (Bol True) Nothing Nothing
-- | Dynamic 'false'.
falseXObj :: XObj
falseXObj = XObj (Bol False) Nothing Nothing
-- | Applies an XObj transformation over all atomic XObjs in a form, retaining
-- list and array structure.
walk :: (XObj -> XObj) -> XObj -> XObj
walk f (XObj (Arr xs) i t) = XObj (Arr (map (walk f) xs)) i t
walk f (XObj (Lst xs) i t) = XObj (Lst (map (walk f) xs)) i t
walk f x = f x

18
src/Qualify.hs
View File

@ -253,6 +253,24 @@ qualifyLet typeEnv globalEnv env x@(XObj (Lst [letExpr@(XObj Let _ _), bind@(XOb
pure (Qualified (XObj (Lst [letExpr, XObj (Arr qualifiedBindings) bindi bindt, qualifiedBody]) i t))
where
qualifyBinding :: (Env, [XObj]) -> (XObj, XObj) -> Either QualificationError (Env, [XObj])
qualifyBinding (e, bs) (s@(XObj (Sym path _) _ _), o@(XObj (Lst [(XObj (Fn _ _) _ _), _, _]) _ _)) =
do
-- Let bindings to anonymous functions may recursively call themselves,
-- qualify the symbols appropriately by adding a recursion environment.
-- e.g. (let [f (fn [x] (if (= x 1) x (f (dec x))))])
-- Environment parenting is a bit nuanced here; the recursive reference
-- needs to be stored in a recursive env to mark the symbol correctly.
-- However, we also need to ensure captured variables are still marked
-- as such, which is based on env nesting level, and we need to ensure
-- the recursive reference isn't accidentally captured.
let Just origin = E.parent e
recursionEnv <- fixLeft (pure (E.recursive (Just e) (Just ("let-recurse-env")) 0))
envWithSelf <- fixLeft (E.insertX recursionEnv path s)
qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv (E.setParent e (E.setParent origin envWithSelf)) o)
updated <- (replaceLeft (FailedToQualifySymbols x) (E.insertX e path s))
(pure (updated, bs ++ [s, qualified]))
where
fixLeft = replaceLeft (FailedToQualifyDeclarationName x)
qualifyBinding (e, bs) (s@(XObj (Sym path _) _ _), o) =
do
qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv e o)

9
test/recursion.carp
View File

@ -21,6 +21,11 @@
(defn recursion-test-2 []
(A.flurb 9 6))
;; let bindings may be recursive in static contexts (issue #402)
(defn letrec-test []
(let [f (fn [x] (if (= x 1) x (f (dec x))))]
(f 10)))
(deftest test
(assert-equal test
120
@ -30,4 +35,8 @@
35
(recursion-test-2)
"Ensure that problem with recursion in modules is resolved.")
(assert-equal test
1
(letrec-test)
"Let bindings bound to lambdas can call themselves ('let-rec' support)")
)