diff options
Diffstat (limited to 'TypeCheck.hs')
| -rw-r--r-- | TypeCheck.hs | 234 |
1 files changed, 234 insertions, 0 deletions
diff --git a/TypeCheck.hs b/TypeCheck.hs new file mode 100644 index 0000000..36d98c8 --- /dev/null +++ b/TypeCheck.hs @@ -0,0 +1,234 @@ +module TypeCheck(typeCheck) where + +import Control.Monad +import Data.Maybe +import qualified Data.Map.Strict as Map + +import AST +import Defs +import Pretty +import TypeRules + + +data DBItem = DBVar Type | DBFunc (Maybe Type) [Type] + +type TypeDB = [Map.Map Name DBItem] + +dbFind :: TypeDB -> Name -> Maybe DBItem +dbFind db name = findJust $ map (Map.lookup name) db + where findJust [] = Nothing + findJust (Just x:_) = Just x + findJust (Nothing:l) = findJust l + +dbFindTop :: TypeDB -> Name -> Maybe DBItem +dbFindTop [] _ = error "dbFindTop on empty scope stack" +dbFindTop (m:_) name = Map.lookup name m + +dbSet :: TypeDB -> Name -> DBItem -> TypeDB +dbSet [] _ _ = error "dbSet on empty scope stack" +dbSet (m:ms) name val = Map.insert name val m : ms + +emptyDB :: TypeDB +emptyDB = [Map.fromList + [("putc", DBFunc Nothing [TChar]), + ("putint", DBFunc Nothing [TInt]), + ("getc", DBFunc (Just TInt) []), + ("_builtin_malloc", DBFunc (Just $ TArr TChar Nothing) [TInt])]] + +withScope :: TypeDB -> (TypeDB -> a) -> a +withScope db f = f (Map.empty : db) + + +typeCheck :: Program -> Error Program +typeCheck (Program vars funcs) = do + db <- foldM registerDVar emptyDB vars + >>= \db' -> foldM registerDFunc db' funcs + vars' <- mapM (annotateDVar db) vars + funcs' <- mapM (annotateDFunc db) funcs + return $ Program vars' funcs' + + +registerDVar :: TypeDB -> DVar -> Error TypeDB +registerDVar db (DVar t n _) = case dbFind db n of + Nothing -> return $ dbSet db n (DBVar t) + Just _ -> Left $ "Duplicate top-level name '" ++ n ++ "'" + +registerDFunc :: TypeDB -> DFunc -> Error TypeDB +registerDFunc db (DFunc rt n al _) = case dbFind db n of + Nothing -> return $ dbSet db n (DBFunc rt (map fst al)) + Just _ -> Left $ "Duplicate top-level name '" ++ n ++ "'" + + +annotateDVar :: TypeDB -> DVar -> Error DVar +annotateDVar db (DVar toptype name expr) = do + expr' <- annotateExpr db expr + when (isNothing (typeof expr')) $ + Left $ "Cannot assign void value in global declaration of " ++ name + let typ = fromJust $ typeof expr' + if canCoerce typ toptype + then return $ DVar toptype name expr' + else Left $ "Cannot assign a value of type " ++ pretty typ ++ + " to a variable of type " ++ pretty toptype + +annotateDFunc :: TypeDB -> DFunc -> Error DFunc +annotateDFunc db dfunc@(DFunc rettype name arglist block) = do + when (name == "main" && rettype /= Just TInt) $ + Left $ "Function 'main' should return an int" + let db' = foldl registerArg db arglist + block' <- annotateBlock dfunc db' block + return $ DFunc rettype name arglist block' + where + registerArg :: TypeDB -> (Type, Name) -> TypeDB + registerArg db' (t, n) = dbSet db' n (DBVar t) + +annotateBlock :: DFunc -> TypeDB -> Block -> Error Block +annotateBlock dfunc db (Block sts) = + Block . snd <$> foldM (\(db', l) st -> + (\(db'', st') -> (db'', l ++ [st'])) <$> annotateStatement dfunc db' st) + (db, []) sts + +annotateStatement :: DFunc -> TypeDB -> Statement -> Error (TypeDB, Statement) +annotateStatement _ db (SDecl toptype name expr) = do + expr' <- annotateExpr db expr + when (isNothing (typeof expr')) $ + Left $ "Cannot assign void value in declaration of " ++ name + when (isJust (dbFindTop db name)) $ + Left $ "Duplicate declaration of variable " ++ name + let typ = fromJust $ typeof expr' + if canCoerce typ toptype + then return $ (dbSet db name (DBVar toptype), SDecl toptype name expr') + else Left $ "Cannot assign a value of type " ++ pretty typ ++ + " to a variable of type " ++ pretty toptype +annotateStatement _ db (SAs ae expr) = do + ae' <- annotateAsExpr db ae + expr' <- annotateExpr db expr + when (isNothing (typeof expr')) $ + Left $ "Cannot assign a void value in assignment of " ++ pretty ae + let typ = fromJust $ typeof expr' + let aetyp = fromJust $ typeof ae' + when (not $ isBasicType aetyp) $ + Left $ "Cannot assign to a location of type " ++ pretty aetyp + when (not $ canCoerce typ aetyp) $ + Left $ "Cannot assign a value of type " ++ pretty typ ++ + " to a location of type " ++ pretty aetyp + return (db, SAs ae' expr') +annotateStatement dfunc db (SIf expr bl1 bl2) = do + expr' <- annotateExpr db expr + when (isNothing (typeof expr')) $ + Left $ "Cannot use void value in 'if' condition" + when (not $ canCoerce (fromJust (typeof expr')) TInt) $ + Left $ "Cannot use type " ++ pretty (fromJust (typeof expr')) ++ " in 'if' condition" + bl1' <- withScope db $ flip (annotateBlock dfunc) bl1 + bl2' <- withScope db $ flip (annotateBlock dfunc) bl2 + return (db, SIf expr' bl1' bl2') +annotateStatement dfunc db (SWhile expr bl) = do + expr' <- annotateExpr db expr + when (isNothing (typeof expr')) $ + Left $ "Cannot use void value in 'while' condition" + when (not $ canCoerce (fromJust (typeof expr')) TInt) $ + Left $ "Cannot use type " ++ pretty (fromJust (typeof expr')) ++ " in 'while' condition" + bl' <- withScope db $ flip (annotateBlock dfunc) bl + return (db, SWhile expr' bl') +annotateStatement (DFunc Nothing _ _ _) db (SReturn Nothing) = + return (db, SReturn Nothing) +annotateStatement (DFunc (Just _) _ _ _) _ (SReturn Nothing) = + Left "Cannot return void value from non-void function" +annotateStatement (DFunc mrt _ _ _) db (SReturn (Just expr)) = do + expr' <- annotateExpr db expr + case mrt of + Nothing -> Left $ "Cannot return non-void value from void function" + Just rt -> do + when (isNothing (typeof expr')) $ + Left $ "Cannot use void value in 'return'" + when (not $ canCoerce (fromJust (typeof expr')) rt) $ + Left $ "Cannot coerce type " ++ pretty (fromJust (typeof expr')) ++ " to " ++ pretty rt ++ + " in 'return'" + return (db, SReturn (Just expr')) +annotateStatement _ db (SExpr expr) = (\expr' -> (db, SExpr expr')) <$> annotateExpr db expr + +annotateExpr :: TypeDB -> Expression -> Error Expression +annotateExpr db (EBin bo e1 e2 _) = do + e1' <- annotateExpr db e1 + e2' <- annotateExpr db e2 + when (isNothing (typeof e1')) $ Left $ "Use of void value in expression: " ++ show e1' + when (isNothing (typeof e2')) $ Left $ "Use of void value in expression: " ++ show e2' + let t1 = fromJust $ typeof e1' + t2 = fromJust $ typeof e2' + rt <- let errval = Left $ "Operator " ++ pretty bo ++ " doesn't take" ++ + " arguments of types " ++ pretty t1 ++ " and " ++ + pretty t2 + in maybe errval return $ retTypeBO bo t1 t2 + return $ EBin bo e1' e2' (Just rt) +annotateExpr db (EUn uo e _) = do + e' <- annotateExpr db e + when (isNothing (typeof e')) $ Left "Use of void value in expression" + let t = fromJust $ typeof e' + rt <- let errval = Left $ "Unary operator " ++ pretty uo ++ " doesn't take" ++ + " an argument of type " ++ pretty t + in maybe errval return $ retTypeUO uo t + return $ EUn uo e' (Just rt) +annotateExpr _ (ELit lit@(LInt _) _) = return $ ELit lit (Just TInt) +annotateExpr _ (ELit lit@(LChar _) _) = return $ ELit lit (Just TChar) +annotateExpr db (ELit lit@(LVar n) _) = case dbFind db n of + Nothing -> Left $ "Use of undeclared variable " ++ n ++ " in expression" + Just (DBVar t) -> return $ ELit lit (Just t) + Just (DBFunc _ _) -> Left $ "Cannot use function " ++ n ++ " in expression" +annotateExpr db (ELit (LCall n as) _) = do + as' <- mapM (annotateExpr db) as + case dbFind db n of + Nothing -> Left $ "Use of undeclared function " ++ n + Just (DBVar t) -> Left $ "Cannot call variable of type " ++ pretty t + Just (DBFunc mrt ats) -> do + when (length as' /= length ats) $ + Left $ "Function '" ++ n ++ "' expected " ++ show (length ats) ++ + " arguments but got " ++ show (length as') + forM_ (zip as' ats) $ \(arg, at) -> do + when (isNothing (typeof arg)) $ + Left "Use of void value in function argument" + if canCoerce (fromJust $ typeof arg) at + then return () + else Left $ "Argument of " ++ n ++ " has type " ++ pretty at ++ + " but value of type " ++ pretty (fromJust $ typeof arg) ++ + " was given" + return $ ELit (LCall n as') mrt +annotateExpr db (ESubscript arr sub _) = do + arr' <- annotateExpr db arr + sub' <- annotateExpr db sub + let subtyp = fromJust (typeof sub') + when (subtyp /= TInt) $ + Left $ "Type of array subscript should be int, but is " ++ pretty subtyp + case fromJust (typeof arr') of + TArr et _ -> return $ ESubscript arr' sub' (Just et) + _ -> Left $ "Subscripted expression is not an array: " ++ pretty arr +annotateExpr db (ECast t e) = do + e' <- annotateExpr db e + let typ = fromJust (typeof e') + if canCast typ t + then return $ ECast t e' + else Left $ "Cannot cast value of type " ++ pretty typ ++ " to type " ++ pretty t +annotateExpr db e@(ENew t sze) = do + sze' <- annotateExpr db sze + case typeof sze' of + Nothing -> Left $ "Use of void value in array length in 'new' expression: " ++ pretty e + Just TInt -> return () + Just szet -> Left $ "Type of array length in 'new' expression should be int, is " ++ pretty szet + if isBasicType t + then return $ ENew t sze' + else Left $ "Can only allocate arrays of basic types using 'new': " ++ pretty e + +annotateAsExpr :: TypeDB -> AsExpression -> Error AsExpression +annotateAsExpr db (AEVar n _) = case dbFind db n of + Nothing -> Left $ "Use of undeclared variable " ++ n ++ " in assignment expression" + Just (DBVar t) -> return $ AEVar n (Just t) + Just (DBFunc _ _) -> Left $ "Cannot use function " ++ n ++ " in assignment expression" +annotateAsExpr db (AESubscript ae expr _) = do + ae' <- annotateAsExpr db ae + expr' <- annotateExpr db expr + case typeof expr' of + Nothing -> Left $ "Use of void value in array index in assignment expression" + Just TInt -> return () + Just t -> Left $ "Use of non-int type " ++ pretty t ++ " in array index in assignment expression" + case fromJust (typeof ae') of + TArr t _ -> return $ AESubscript ae' expr' (Just t) + t -> Left $ "Indexed expression '" ++ pretty ae ++ "' has non-array type " ++ pretty t ++ + " in assignment expression" |