GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-24 03:52:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

Transfer: let expressions caused non-termination due to excessive strictness, fixed.

Browse Source
This commit is contained in:
bringert
2005-11-29 17:40:43 +00:00
parent f85a51515d
commit 9cc9a1fa8b
1 changed files with 8 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
src/Transfer/Interpreter.hs
View File

@@ -45,6 +45,9 @@ lookupEnv (Env e) id =
prEnv :: Env -> String prEnv :: Env -> String
prEnv (Env e) = unlines [ printTree id ++ ": " ++ printValue v | (id,v) <- e ] prEnv (Env e) = unlines [ printTree id ++ ": " ++ printValue v | (id,v) <- e ]
seqEnv :: Env -> Env
seqEnv (Env e) = Env $! deepSeqList [ fst p `seq` p | p <- e ]
-- | The built-in types and functions. -- | The built-in types and functions.
builtin :: Env builtin :: Env
builtin = builtin =
@@ -93,18 +96,18 @@ addModuleEnv env (Module ds) =
eval :: Env -> Exp -> Value eval :: Env -> Exp -> Value
eval env x = case x of eval env x = case x of
ELet defs exp2 -> ELet defs exp2 ->
let env' = deepSeqList [ v `seq` (id, v) | LetDef id _ e <- defs, let env' = [ (id, v) | LetDef id _ e <- defs,
let v = eval env' e] let v = eval env' e]
`addToEnv` env `addToEnv` env
in eval env' exp2 in eval (seqEnv env') exp2
ECase exp cases -> ECase exp cases ->
let v = eval env exp let v = eval env exp
r = case firstMatch v cases of r = case firstMatch v cases of
Nothing -> error $ "No pattern matched " ++ printValue v Nothing -> error $ "No pattern matched " ++ printValue v
Just (e,bs) -> eval (bs `addToEnv` env) e Just (e,bs) -> eval (bs `addToEnv` env) e
in v `seq` r in v `seq` r
EAbs _ _ -> VClos env $! x EAbs _ _ -> VClos env x
EPi _ _ _ -> VClos env $! x EPi _ _ _ -> VClos env x
EApp exp1 exp2 -> EApp exp1 exp2 ->
let v1 = eval env exp1 let v1 = eval env exp1
v2 = eval env exp2 v2 = eval env exp2