Browse files

do some type check

  • Loading branch information...
1 parent ee0fdd4 commit 61359d10791e708cc6d1f4a8cb28a7dac54f81e1 @hayamiz committed Dec 5, 2011
Showing with 73 additions and 7 deletions.
  1. +73 −7 src/Semantic.hs
View
80 src/Semantic.hs
@@ -6,7 +6,7 @@ import Text.ParserCombinators.Parsec
import Parser
import qualified Data.Map as Map
-data Block = FuncBlock
+data Block = FuncBlock FuncInfo
| LoopBlock
| CompBlock
| Root
@@ -32,6 +32,9 @@ data SemError = InvalidBreakError SourcePos
| UndefinedNameError String SourcePos
| UndefinedFunctionError String SourcePos
| InvalidLvalError CExp
+ | TypeError TypeExp TypeExp CExp -- 1st ... expected, 2nd ... actual
+ | ArityError Ident Int Int SourcePos -- 1st ... func name, 2nd ... expected arity, 3rd ... actual arity
+ | TypeUndecidable CExp
| TypeConflictError FuncInfo
deriving (Show)
@@ -84,7 +87,7 @@ doSemCheckCDef env cdef =
case cdef of
CFuncDef typ id params stmt pos ->
doSemCheckCStmt
- (Env {block = FuncBlock,
+ (Env {block = FuncBlock (FuncInfo typ id (map fst params) (Just pos)),
funcTable = (funcTable env),
varTable = foldl (\tbl param -> insertParam param tbl pos)
Map.empty params,
@@ -121,8 +124,10 @@ doSemCheckCStmt env stmt =
in
(concatMap (doSemCheckCVarDecl env_) vardecls) ++
(concatMap (doSemCheckCStmt env_) stmts)
- CIfStmt e stmt Nothing _ -> -- TODO: check type of predicate exp
- (doSemCheckCExp env e) ++ (doSemCheckCStmt env stmt)
+ CIfStmt e stmt Nothing pos -> -- TODO: check type of predicate exp
+ let typErrs = doTypeCheckCExp env TypInt e
+ in
+ (doSemCheckCExp env e) ++ (doSemCheckCStmt env stmt) ++ typErrs
CIfStmt e stmt (Just elseStmt) _ ->
(doSemCheckCExp env e) ++
(doSemCheckCStmt env stmt) ++
@@ -139,6 +144,18 @@ doSemCheckCStmt env stmt =
CNopStmt _ ->
[]
+doTypeCheckCExp :: Env -> TypeExp -> CExp -> [SemError]
+doTypeCheckCExp env expectedTyp expr =
+ let (fixErrs, fixedTyp) = fixType env expr
+ in
+ case fixedTyp of
+ Nothing -> [TypeUndecidable expr]
+ Just typ ->
+ if expectedTyp == typ then
+ []
+ else
+ [TypeError expectedTyp typ expr]
+
insertCVarDecl :: CVarDecl -> Map.Map String VarInfo -> Map.Map String VarInfo
insertCVarDecl (typ, id, pos) table =
Map.insert id (VarInfo typ pos) table
@@ -151,7 +168,7 @@ isBreakable env =
case (parent env) of
Just p -> isBreakable p
Nothing -> False
- FuncBlock -> False
+ FuncBlock _ -> False
Root -> False
isContinuable = isBreakable
@@ -172,14 +189,24 @@ doSemCheckCExp env expr =
in
case (Map.lookup id (funcTable env)) of
Nothing -> (UndefinedFunctionError id pos) : argErrs
- Just (FuncInfo typ id paramTyps _) -> -- TODO: arg type check
- argErrs
+ Just (fi @ (FuncInfo typ id paramTyps _)) -> -- TODO: arg type check
+ argErrs ++ (doTypeCheckCFuncallExp env fi id args pos)
CUnaryExp op e _ -> doSemCheckCExp env e
CBinaryExp op e1 e2 _ ->
(doSemCheckCExp env e1) ++ (doSemCheckCExp env e2)
CAssignExp e1 e2 _ -> -- TODO: type checking
(doSemCheckLval env e1) ++ (doSemCheckCExp env e2)
+doTypeCheckCFuncallExp :: Env -> FuncInfo -> Ident -> [CExp] -> SourcePos -> [SemError]
+doTypeCheckCFuncallExp env fi id args pos =
+ case fi of
+ FuncInfo typ id paramTyps _ ->
+ if length paramTyps == length args then
+ concatMap (\(typ, arg) -> doTypeCheckCExp env typ arg)
+ (zip paramTyps args)
+ else
+ [ArityError id (length paramTyps) (length args) pos]
+
doSemCheckLval :: Env -> CExp -> [SemError]
doSemCheckLval env expr =
case expr of
@@ -199,5 +226,44 @@ isIdentDefined env id =
Just p -> isIdentDefined p id
Nothing -> False
+lookupVarInfo :: Env -> Ident -> Maybe VarInfo
+lookupVarInfo env id =
+ case Map.lookup id (varTable env) of
+ Just vi -> Just vi
+ Nothing ->
+ case parent env of
+ Just p -> lookupVarInfo p id
+ Nothing -> Nothing
+
+lookupFuncInfo :: Env -> Ident -> Maybe FuncInfo
+lookupFuncInfo env id =
+ case Map.lookup id (funcTable env) of
+ Just fi -> Just fi
+ Nothing ->
+ case parent env of
+ Just p -> lookupFuncInfo p id
+ Nothing -> Nothing
+
doSemCheckCVarDecl :: Env -> CVarDecl -> [SemError]
doSemCheckCVarDecl a b = []
+
+fixType :: Env -> CExp -> ([SemError], Maybe TypeExp)
+fixType env expr =
+ case expr of
+ CLitIntExp _ _ -> ([], Just TypInt)
+ CParenExp e _ -> fixType env e
+ CIdentExp id pos->
+ case lookupVarInfo env id of
+ Just (VarInfo typ _) -> ([], Just typ)
+ Nothing -> ([], Nothing) -- UndefinedNameError is raised by doSemCheckCExp
+ CFuncallExp id _ pos ->
+ case lookupFuncInfo env id of
+ Just (FuncInfo typ _ _ _) -> ([], Just typ)
+ Nothing -> ([], Nothing) -- UndefinedNameError is raised by doSemCheckCExp
+ CUnaryExp _ e _ -> fixType env e
+ CBinaryExp _ e1 e2 _ -> coerceType env e1 e2
+ CAssignExp e _ _ -> fixType env e
+
+coerceType :: Env -> CExp -> CExp -> ([SemError], Maybe TypeExp)
+coerceType env e1 e2 = -- TODO:
+ fixType env e1

0 comments on commit 61359d1

Please sign in to comment.