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

Environments know their nesting level (nr of nested _functions_, not environments).

Browse Source
This commit is contained in:
Erik Svedäng 2018-08-28 14:23:44 +02:00
parent a72f01e9ec
commit 60abdba056
7 changed files with 70 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Concretize.hs
View File

@ -61,7 +61,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
visitList _ env (XObj (Lst [defn@(XObj Defn _ _), nameSymbol, args@(XObj (Arr argsArr) _ _), body]) _ t) =
do mapM_ (concretizeTypeOfXObj typeEnv) argsArr
let functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv
let functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv 0
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
extendEnv e argSymName arg)
functionEnv argsArr
@ -80,7 +80,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
do let Just ii = i
Just funcTy = t
-- | TODO: This code is a copy of the one above in Defn, remove duplication:
functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv
functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv (envFunctionNestingLevel env + 1)
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
extendEnv e argSymName arg)
functionEnv argsArr

4
src/Deftype.hs
View File

@ -27,7 +27,7 @@ moduleForDeftype typeEnv env pathStrings typeName typeVariables rest i existingE
let typeModuleName = typeName
typeModuleEnv = case existingEnv of
Just env -> env
Nothing -> Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv
Nothing -> Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv 0
-- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
insidePath = pathStrings ++ [typeModuleName]
@ -54,7 +54,7 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
let typeModuleName = typeName
typeModuleEnv = case existingEnv of
Just env -> env
Nothing -> Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv
Nothing -> Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv 0
insidePath = pathStrings ++ [typeModuleName]
in do validateMemberCases typeEnv [] rest
let structTy = StructTy typeName []

6
src/Eval.hs
View File

@ -145,7 +145,7 @@ eval env xobj =
return $ do okX <- x'
(Right [n, okX]))
(pairwise bindings)
let innerEnv = Env Map.empty (Just env) (Just "LET") [] InternalEnv
let innerEnv = Env Map.empty (Just env) (Just "LET") [] InternalEnv 0
let okBindings = sequence bind
case okBindings of
(Left err) -> return (Left err)
@ -295,7 +295,7 @@ checkMatchingNrOfArgs xobj params args =
-- | Apply a function to some arguments. The other half of 'eval'.
apply :: Env -> XObj -> [XObj] -> [XObj] -> StateT Context IO (Either EvalError XObj)
apply env body params args =
let insideEnv = Env Map.empty (Just env) Nothing [] InternalEnv
let insideEnv = Env Map.empty (Just env) Nothing [] InternalEnv 0
allParams = map getName params
[properParams, restParams] = case splitWhen isRestArgSeparator allParams of
[a, b] -> [a, b]
@ -726,7 +726,7 @@ specialCommandDefmodule xobj moduleName innerExpressions =
return (Left (EvalError ("Can't redefine '" ++ moduleName ++ "' as module.")))
Nothing ->
do let parentEnv = getEnv env pathStrings
innerEnv = Env (Map.fromList []) (Just parentEnv) (Just moduleName) [] ExternalEnv
innerEnv = Env (Map.fromList []) (Just parentEnv) (Just moduleName) [] ExternalEnv 0
newModule = XObj (Mod innerEnv) (info xobj) (Just ModuleTy)
globalEnvWithModuleAdded = envInsertAt env (SymPath pathStrings moduleName) (Binder emptyMeta newModule)
ctx' = Context globalEnvWithModuleAdded typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode -- TODO: also change

2
src/InitialTypes.hs
View File

@ -324,6 +324,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
, envModuleName = Nothing
, envUseModules = []
, envMode = InternalEnv
, envFunctionNestingLevel = envFunctionNestingLevel env
}
-- Need to fold (rather than map) to make the previous bindings accessible to the later ones, i.e. (let [a 100 b a] ...)
in foldM createBinderForLetPair (Right emptyInnerEnv) pairs
@ -347,6 +348,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
, envModuleName = Nothing
, envUseModules = []
, envMode = InternalEnv
, envFunctionNestingLevel = envFunctionNestingLevel env
}
where
createBinderForParam :: XObj -> State Integer (String, Binder)

7
src/Obj.hs
View File

@ -394,6 +394,7 @@ data Env = Env { envBindings :: Map.Map String Binder
, envModuleName :: Maybe String
, envUseModules :: [SymPath]
, envMode :: EnvMode
, envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting
} deriving (Show, Eq)
newtype TypeEnv = TypeEnv { getTypeEnv :: Env }
@ -430,9 +431,11 @@ prettyEnvironmentChain env =
name = case envModuleName env of
Just n -> n
Nothing -> "<env has no name>"
otherInfo = "(" ++ show (envMode env) ++ ", lvl " ++ show (envFunctionNestingLevel env) ++ ")"
in (if length bs < 20
then "'" ++ name ++ "':\n" ++ (joinWith "\n" $ filter (/= "") (map (showBinderIndented 4) (Map.toList (envBindings env))))
else "'" ++ name ++ "':\n Too big to show bindings.")
then "'" ++ name ++ "' " ++ otherInfo ++ ":\n" ++ (joinWith "\n" $ filter (/= "")
(map (showBinderIndented 4) (Map.toList (envBindings env))))
else "'" ++ name ++ "' " ++ otherInfo ++ ":\n Too big to show bindings.")
++
(case envParent env of
Just parent -> "\nWITH PARENT ENV " ++ prettyEnvironmentChain parent

10
src/Qualify.hs
View File

@ -32,16 +32,17 @@ setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [defn@(XObj Defn _ _),
-- It is marked as RecursionEnv basically is the same thing as external to not mess up lookup.
-- Inside the recursion env is the function env that contains bindings for the arguments of the function.
-- Note: These inner envs is ephemeral since they are not stored in a module or global scope.
let recursionEnv = Env Map.empty (Just env) (Just (functionName ++ "-recurse-env")) [] RecursionEnv
let recursionEnv = Env Map.empty (Just env) (Just (functionName ++ "-recurse-env")) [] RecursionEnv 0
envWithSelf = extendEnv recursionEnv functionName sym
functionEnv = Env Map.empty (Just envWithSelf) Nothing [] InternalEnv
functionEnv = Env Map.empty (Just envWithSelf) Nothing [] InternalEnv 0
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
in XObj (Lst [defn, sym, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [fn@(XObj (Fn _ _) _ _),
args@(XObj (Arr argsArr) _ _),
body])
i t) =
let functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv
let lvl = envFunctionNestingLevel env
functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv (lvl + 1)
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
in XObj (Lst [fn, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [the@(XObj The _ _), typeXObj, value]) i t) =
@ -53,7 +54,8 @@ setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [def@(XObj Def _ _), s
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj (Arr bindings) bindi bindt), body]) i t) =
if even (length bindings)
then let Just ii = i
innerEnv = Env Map.empty (Just env) (Just ("let-env-" ++ show (infoIdentifier ii))) [] InternalEnv
lvl = envFunctionNestingLevel env
innerEnv = Env Map.empty (Just env) (Just ("let-env-" ++ show (infoIdentifier ii))) [] InternalEnv lvl
(innerEnv', bindings') =
foldl' (\(e, bs) (s@(XObj (Sym (SymPath _ binderName) _) _ _), o) ->
let qualified = setFullyQualifiedSymbols typeEnv globalEnv e o

62
src/StartingEnv.hs
View File

@ -18,7 +18,12 @@ coreModules carpDir = [carpDir ++ "/core/Core.carp"]
-- | The array module contains functions for working with the Array type.
arrayModule :: Env
arrayModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "Array", envUseModules = [], envMode = ExternalEnv }
arrayModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Array"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where bindings = Map.fromList [ templateNth
, templateAllocate
, templateEMap
@ -39,7 +44,12 @@ arrayModule = Env { envBindings = bindings, envParent = Nothing, envModuleName =
-- | The Pointer module contains functions for dealing with pointers.
pointerModule :: Env
pointerModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "Pointer", envUseModules = [], envMode = ExternalEnv }
pointerModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Pointer"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where bindings = Map.fromList [ templatePointerCopy, templatePointerEqual ]
-- | A template function for copying (= deref:ing) any pointer.
@ -65,7 +75,12 @@ templatePointerEqual = defineTemplate
-- | The System module contains functions for various OS related things like timing and process control.
systemModule :: Env
systemModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "System", envUseModules = [], envMode = ExternalEnv }
systemModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "System"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where bindings = Map.fromList [ templateExit ]
-- | A template function for exiting.
@ -84,7 +99,12 @@ maxArity = 9
-- | The Function module contains functions for dealing with functions.
functionModule :: Env
functionModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "Function", envUseModules = [], envMode = ExternalEnv }
functionModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Function"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where
bindEnv env = let Just name = envModuleName env
in (name, Binder emptyMeta (XObj (Mod env) Nothing Nothing))
@ -98,6 +118,7 @@ generateInnerFunctionModule arity =
, envModuleName = Just ("Arity" ++ show arity)
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0
}
where
alphabet = ['d'..'y']
@ -134,7 +155,12 @@ generateTemplateFuncStrOrPrn name funcTy = defineTemplate
-- | The dynamic module contains dynamic functions only available in the repl and during compilation.
dynamicModule :: Env
dynamicModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "Dynamic", envUseModules = [], envMode = ExternalEnv }
dynamicModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Dynamic"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where bindings = Map.fromList $
[ addCommand "list?" 1 commandIsList
, addCommand "array?" 1 commandIsArray
@ -182,7 +208,12 @@ dynamicModule = Env { envBindings = bindings, envParent = Nothing, envModuleName
-- | A submodule of the Dynamic module. Contains functions for working with strings in the repl or during compilation.
dynamicStringModule :: Env
dynamicStringModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "String", envUseModules = [], envMode = ExternalEnv }
dynamicStringModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "String"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where bindings = Map.fromList [ addCommand "char-at" 2 commandCharAt
, addCommand "index-of" 2 commandIndexOf
, addCommand "substring" 3 commandSubstring
@ -193,7 +224,12 @@ dynamicStringModule = Env { envBindings = bindings, envParent = Nothing, envModu
-- | A submodule of the Dynamic module. Contains functions for working with the active Carp project.
dynamicProjectModule :: Env
dynamicProjectModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "Project", envUseModules = [], envMode = ExternalEnv }
dynamicProjectModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Project"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where bindings = Map.fromList [ addCommand "config" 2 commandProjectConfig
]
@ -211,11 +247,12 @@ templateEnumToInt = defineTemplate
-- | The global environment before any code is run.
startingGlobalEnv :: Bool -> Env
startingGlobalEnv noArray =
Env { envBindings = bindings,
envParent = Nothing,
envModuleName = Nothing,
envUseModules = [SymPath [] "String"],
envMode = ExternalEnv
Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Nothing
, envUseModules = [SymPath [] "String"]
, envMode = ExternalEnv
, envFunctionNestingLevel = 0
}
where bindings = Map.fromList $ [ register "not" (FuncTy [BoolTy] BoolTy)
, register "NULL" (VarTy "a")
@ -234,6 +271,7 @@ startingTypeEnv = Env { envBindings = bindings
, envModuleName = Nothing
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0
}
where bindings = Map.fromList
$ [ interfaceBinder "copy" (FuncTy [(RefTy (VarTy "a"))] (VarTy "a"))