diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Syntax.hs | 7 | ||||
| -rw-r--r-- | src/Typecheck.hs | 58 |
2 files changed, 44 insertions, 21 deletions
diff --git a/src/Syntax.hs b/src/Syntax.hs index f5d9c2d..18949d2 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -19,6 +19,7 @@ data Expr = Var Idnt | Deref Expr | Match Expr [(Idnt, Idnt, Expr)] -- Variant,Binder, Expression | Proj Idnt Expr + | Annot Expr Typ deriving(Eq,Show) data Com = Skip | Seq Com Com @@ -29,10 +30,14 @@ data Com = Skip | Alloc Idnt Expr Com | Save Idnt Expr | SMatch Expr [(Idnt, Idnt, Com)] + | FunctionCall Idnt Idnt [Expr] -- variable function_name parameters deriving(Eq,Show) -data FuncDecl = Func Idnt [Idnt] [(Idnt,Expr)] Com Expr +data FuncDecl = Func Idnt [(Idnt, Typ)] [(Idnt,Expr)] Com Expr -- function_name [parameters] [local variables] body return_val deriving(Eq,Show) +data FuncSign = FuncSign [Typ] Typ + deriving(Eq,Show) +type FuncEnv = [(Idnt,FuncSign)] data Program = P [FuncDecl] [(Idnt, Int)] Com deriving(Eq,Show) diff --git a/src/Typecheck.hs b/src/Typecheck.hs index d8c0187..8f09627 100644 --- a/src/Typecheck.hs +++ b/src/Typecheck.hs @@ -90,6 +90,9 @@ inferExpr (Proj name e) env = do case lookup name tt of Just typ -> return typ Nothing -> throwError $ "Record " ++show e ++ "doesn't have field" ++ name +inferExpr (Annot e t) env = do + checkExpr e env t + return t checkExpr :: Expr -> Environment -> Typ -> Error () checkExpr e@(Add e1 e2) env t = do @@ -113,46 +116,61 @@ checkExpr e env t = do bool = TVariant [("True",TRecord []),("False", TRecord [])] -cenvlookup :: Idnt -> TypeDict -> Com -> Error Typ +cenvlookup ::(Show a,Eq a) => a-> [(a,b)] -> Com -> Error b cenvlookup name env c = case lookup name env of Just t -> return t - Nothing -> throwError $ "Variable "++ name ++ "not defined in expr" ++ show c + Nothing -> throwError $ "name "++ show name ++ "not visible in expr" ++ show c -wellFormed :: Com ->Environment -> Error () -wellFormed Skip _= return () -wellFormed (Seq s1 s2) env = do - wellFormed s1 env - wellFormed s2 env -wellFormed (If e c1 c2) env = do +wellFormed :: Com ->Environment -> FuncEnv-> Error () +wellFormed Skip _ _= return () +wellFormed (Seq s1 s2) env fe = do + wellFormed s1 env fe + wellFormed s2 env fe +wellFormed (If e c1 c2) env fe = do checkExpr e env bool - wellFormed c1 env - wellFormed c2 env -wellFormed (While e c) env = do + wellFormed c1 env fe + wellFormed c2 env fe +wellFormed (While e c) env fe= do checkExpr e env bool - wellFormed c env -wellFormed c@(Asgn v e) env = do + wellFormed c env fe +wellFormed c@(Asgn v e) env _ = do vt <- cenvlookup v env c et <- inferExpr e env if vt==et then return () else throwError $ "Variable " ++ show v ++ "::" ++ show vt ++ " was assigned expression " ++ show e ++ "::" ++ show et -wellFormed (Decl v e c) env= do +wellFormed (Decl v e c) env fe= do et <- inferExpr e env - wellFormed c (insert v et env) -wellFormed (Alloc v e c) env = do + wellFormed c (insert v et env) fe +wellFormed (Alloc v e c) env fe = do et <- inferExpr e env - wellFormed c (insert v (TPtr et) env) -wellFormed c@(Save v e) env = do + wellFormed c (insert v (TPtr et) env) fe +wellFormed c@(Save v e) env _ = do vt <- cenvlookup v env c et <- inferExpr e env if vt==TPtr et then return () else throwError $ "Expression" ++ show e ++ "::" ++ show et ++ " was saved to pointer "++show v ++ " of type" ++ show vt -wellFormed c@(SMatch e cases) env = do +wellFormed c@(SMatch e cases) env fe= do varType <- inferExpr e env variants <- assertVar varType e mapM (\(v,bind,c) -> do tt <- envlookup v variants e - wellFormed c (insert bind tt env)) cases + wellFormed c (insert bind tt env) fe) cases subset (map fst variants) (map (\(_,v,_)->v) cases) c return () +wellFormed c@(FunctionCall v f args) env fa= do + (FuncSign argTypes retType) <- cenvlookup f fa c + vt <- cenvlookup v env c + if vt/=retType then throwError $ "Returned function type"++show retType++" doesn't match up with variable type " ++show vt ++ " in " ++ show c + else argsOk args argTypes + where argsOk:: [Expr] ->[Typ] ->Error () + argsOk [] [] =return () + argsOk (_:_) [] = throwError $ "Too many arguments in function call" ++ show c + argsOk [] (_:_) = throwError $ "Not enough arguments in function call" ++ show c + argsOk (x:xs) (y:ys) = do + checkExpr x env y + argsOk xs ys + + + |