diff --git a/src/Concretize.hs b/src/Concretize.hs index 7928fc07f..a18fc3a5d 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -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) = diff --git a/src/InitialTypes.hs b/src/InitialTypes.hs index 09d71ee5e..5506cfd55 100644 --- a/src/InitialTypes.hs +++ b/src/InitialTypes.hs @@ -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 [] )")) - -- 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) diff --git a/src/Obj.hs b/src/Obj.hs index 8abaf3c03..fd11ccf33 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -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 diff --git a/src/Qualify.hs b/src/Qualify.hs index 5f44e8668..d9f088bc9 100644 --- a/src/Qualify.hs +++ b/src/Qualify.hs @@ -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) diff --git a/test/recursion.carp b/test/recursion.carp index db5ab8125..52437c860 100644 --- a/test/recursion.carp +++ b/test/recursion.carp @@ -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)") )