mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
fix: support recursive let bindings in static code (Fix 402) (#1230)
This commit is contained in:
parent
8f055f287a
commit
bda32d6104
@ -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) =
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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)")
|
||||
)
|
||||
|
Loading…
Reference in New Issue
Block a user