Commit 65bfd25c authored by Finn Teegen's avatar Finn Teegen

Fix type of free variables in intermediate language

parent ac2384e7
Change log for curry-frontend Change log for curry-frontend
============================= =============================
Version 1.0.2 (under development)
=============
* Fixed bug with wrong type of free variables in the intermediate language.
Version 1.0.1 Version 1.0.1
============= =============
......
Name: curry-frontend Name: curry-frontend
Version: 1.0.1 Version: 1.0.2
Cabal-Version: >= 1.10 Cabal-Version: >= 1.10
Synopsis: Compile the functional logic language Curry to several Synopsis: Compile the functional logic language Curry to several
intermediate formats intermediate formats
......
...@@ -330,8 +330,8 @@ trAExpr (IL.Apply e1 e2) = trApply e1 e2 ...@@ -330,8 +330,8 @@ trAExpr (IL.Apply e1 e2) = trApply e1 e2
trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e
<*> mapM (inNestedEnv . trAlt) bs <*> mapM (inNestedEnv . trAlt) bs
trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2 trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2
trAExpr (IL.Exist v e) = inNestedEnv $ do trAExpr (IL.Exist v ty e) = inNestedEnv $ do
v' <- newVar (IL.typeOf e) v v' <- newVar ty v
e' <- trAExpr e e' <- trAExpr e
ty' <- trType (IL.typeOf e) ty' <- trType (IL.typeOf e)
return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e'' return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e''
......
...@@ -139,7 +139,7 @@ ppExpr p (Case ev e alts) = parenIf (p > 0) $ ...@@ -139,7 +139,7 @@ ppExpr p (Case ev e alts) = parenIf (p > 0) $
ppEval Flex = text "flex" ppEval Flex = text "flex"
ppExpr p (Or e1 e2) = parenIf (p > 0) $ sep ppExpr p (Or e1 e2) = parenIf (p > 0) $ sep
[nest orIndent (ppExpr 0 e1), char '|', nest orIndent (ppExpr 0 e2)] [nest orIndent (ppExpr 0 e1), char '|', nest orIndent (ppExpr 0 e2)]
ppExpr p (Exist v e) = parenIf (p > 0) $ sep ppExpr p (Exist v _ e) = parenIf (p > 0) $ sep
[text "let" <+> ppIdent v <+> text "free" <+> text "in", ppExpr 0 e] [text "let" <+> ppIdent v <+> text "free" <+> text "in", ppExpr 0 e]
ppExpr p (Let b e) = parenIf (p > 0) $ sep ppExpr p (Let b e) = parenIf (p > 0) $ sep
[text "let" <+> ppBinding b <+> text "in",ppExpr 0 e] [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e]
......
...@@ -156,9 +156,10 @@ showsExpression (Or exp1 exp2) ...@@ -156,9 +156,10 @@ showsExpression (Or exp1 exp2)
. showsExpression exp1 . space . showsExpression exp1 . space
. showsExpression exp2 . showsExpression exp2
. showsString ")" . showsString ")"
showsExpression (Exist ident expr) showsExpression (Exist ident ty expr)
= showsString "(Exist " = showsString "(Exist "
. showsIdent ident . space . showsIdent ident . space
. showsType ty . space
. showsExpression expr . showsExpression expr
. showsString ")" . showsString ")"
showsExpression (Let bind expr) showsExpression (Let bind expr)
......
...@@ -102,7 +102,7 @@ data Expression ...@@ -102,7 +102,7 @@ data Expression
-- |non-deterministic or -- |non-deterministic or
| Or Expression Expression | Or Expression Expression
-- |exist binding (introduction of a free variable) -- |exist binding (introduction of a free variable)
| Exist Ident Expression | Exist Ident Type Expression
-- |let binding -- |let binding
| Let Binding Expression | Let Binding Expression
-- |letrec binding -- |letrec binding
...@@ -127,7 +127,7 @@ instance Expr Expression where ...@@ -127,7 +127,7 @@ instance Expr Expression where
fv (Apply e1 e2) = fv e1 ++ fv e2 fv (Apply e1 e2) = fv e1 ++ fv e2
fv (Case _ e alts) = fv e ++ fv alts fv (Case _ e alts) = fv e ++ fv alts
fv (Or e1 e2) = fv e1 ++ fv e2 fv (Or e1 e2) = fv e1 ++ fv e2
fv (Exist v e) = filter (/= v) (fv e) fv (Exist v _ e) = filter (/= v) (fv e)
fv (Let (Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2) fv (Let (Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)
fv (Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e) fv (Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)
where (vs, es) = unzip [(v, e') | Binding v e' <- bds] where (vs, es) = unzip [(v, e') | Binding v e' <- bds]
......
...@@ -35,7 +35,7 @@ instance Typeable Expression where ...@@ -35,7 +35,7 @@ instance Typeable Expression where
_ -> internalError "IL.Typing.typeOf: application" _ -> internalError "IL.Typing.typeOf: application"
typeOf (Case _ _ as) = typeOf $ head as typeOf (Case _ _ as) = typeOf $ head as
typeOf (Or e _) = typeOf e typeOf (Or e _) = typeOf e
typeOf (Exist _ e) = typeOf e typeOf (Exist _ _ e) = typeOf e
typeOf (Let _ e) = typeOf e typeOf (Let _ e) = typeOf e
typeOf (Letrec _ e) = typeOf e typeOf (Letrec _ e) = typeOf e
typeOf (Typed e _) = typeOf e typeOf (Typed e _) = typeOf e
......
...@@ -109,7 +109,7 @@ ccExpr (Case ea e bs) = do ...@@ -109,7 +109,7 @@ ccExpr (Case ea e bs) = do
bs' <- mapM ccAlt bs bs' <- mapM ccAlt bs
ccCase ea e' bs' ccCase ea e' bs'
ccExpr (Or e1 e2) = Or <$> ccExpr e1 <*> ccExpr e2 ccExpr (Or e1 e2) = Or <$> ccExpr e1 <*> ccExpr e2
ccExpr (Exist v e) = Exist v <$> ccExpr e ccExpr (Exist v ty e) = Exist v ty <$> ccExpr e
ccExpr (Let b e) = Let <$> ccBinding b <*> ccExpr e ccExpr (Let b e) = Let <$> ccBinding b <*> ccExpr e
ccExpr (Letrec bs e) = Letrec <$> mapM ccBinding bs <*> ccExpr e ccExpr (Letrec bs e) = Letrec <$> mapM ccBinding bs <*> ccExpr e
ccExpr (Typed e ty) = flip Typed ty <$> ccExpr e ccExpr (Typed e ty) = flip Typed ty <$> ccExpr e
...@@ -278,9 +278,9 @@ replaceVar v e (Case ev e' bs) ...@@ -278,9 +278,9 @@ replaceVar v e (Case ev e' bs)
= Case ev (replaceVar v e e') (map (replaceVarInAlt v e) bs) = Case ev (replaceVar v e e') (map (replaceVarInAlt v e) bs)
replaceVar v e (Or e1 e2) replaceVar v e (Or e1 e2)
= Or (replaceVar v e e1) (replaceVar v e e2) = Or (replaceVar v e e1) (replaceVar v e e2)
replaceVar v e (Exist w e') replaceVar v e (Exist w ty e')
| v == w = Exist w e' | v == w = Exist w ty e'
| otherwise = Exist w (replaceVar v e e') | otherwise = Exist w ty (replaceVar v e e')
replaceVar v e (Let b e') replaceVar v e (Let b e')
| v `occursInBinding` b = Let b e' | v `occursInBinding` b = Let b e'
| otherwise = Let (replaceVarInBinding v e b) | otherwise = Let (replaceVarInBinding v e b)
......
...@@ -85,7 +85,7 @@ mdlsExpr (IL.Case _ e as) ms = mdlsExpr e (foldr mdlsAlt ms as) ...@@ -85,7 +85,7 @@ mdlsExpr (IL.Case _ e as) ms = mdlsExpr e (foldr mdlsAlt ms as)
mdlsPattern (IL.ConstructorPattern _ c _) = modules c mdlsPattern (IL.ConstructorPattern _ c _) = modules c
mdlsPattern _ = id mdlsPattern _ = id
mdlsExpr (IL.Or e1 e2) ms = mdlsExpr e1 (mdlsExpr e2 ms) mdlsExpr (IL.Or e1 e2) ms = mdlsExpr e1 (mdlsExpr e2 ms)
mdlsExpr (IL.Exist _ e) ms = mdlsExpr e ms mdlsExpr (IL.Exist _ _ e) ms = mdlsExpr e ms
mdlsExpr (IL.Let b e) ms = mdlsBinding b (mdlsExpr e ms) mdlsExpr (IL.Let b e) ms = mdlsBinding b (mdlsExpr e ms)
mdlsExpr (IL.Letrec bs e) ms = foldr mdlsBinding (mdlsExpr e ms) bs mdlsExpr (IL.Letrec bs e) ms = foldr mdlsBinding (mdlsExpr e ms) bs
mdlsExpr _ ms = ms mdlsExpr _ ms = ms
...@@ -286,7 +286,7 @@ trExpr vs env (Let ds e) = do ...@@ -286,7 +286,7 @@ trExpr vs env (Let ds e) = do
e' <- trExpr vs env' e e' <- trExpr vs env' e
case ds of case ds of
[FreeDecl _ vs'] [FreeDecl _ vs']
-> return $ foldr IL.Exist e' $ map varIdent vs' -> return $ foldr (\ (Var ty v) -> IL.Exist v (transType ty)) e' vs'
[d] | all (`notElem` bv d) (qfv emptyMIdent d) [d] | all (`notElem` bv d) (qfv emptyMIdent d)
-> flip IL.Let e' <$> trBinding d -> flip IL.Let e' <$> trBinding d
_ -> flip IL.Letrec e' <$> mapM trBinding ds _ -> flip IL.Letrec e' <$> mapM trBinding ds
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment