diff options
Diffstat (limited to 'TypeCheck.hs')
| -rw-r--r-- | TypeCheck.hs | 99 |
1 files changed, 80 insertions, 19 deletions
diff --git a/TypeCheck.hs b/TypeCheck.hs index 922731d..2b05df1 100644 --- a/TypeCheck.hs +++ b/TypeCheck.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE TupleSections #-} + module TypeCheck(typeCheck) where import Control.Monad +import Data.List import Data.Maybe import qualified Data.Map.Strict as Map @@ -10,7 +13,7 @@ import Pretty import TypeRules -data DBItem = DBVar Type | DBFunc (Maybe Type) [Type] +data DBItem = DBVar Type | DBFunc (Maybe Type) [Type] | DBType Type type TypeDB = [Map.Map Name DBItem] @@ -34,56 +37,79 @@ emptyDB = [Map.fromList ("putint", DBFunc Nothing [TInt]), ("getc", DBFunc (Just TInt) []), ("exit", DBFunc Nothing [TInt]), - ("_builtin_malloc", DBFunc (Just $ TArr TChar Nothing) [TInt])]] + ("_builtin_malloc", DBFunc (Just $ TArr TChar Nothing) [TInt]), + ("char", DBType TChar), + ("int", DBType 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 +typeCheck (Program tdefs vars funcs) = do + -- case topologicalSort + db <- foldM registerDTypedef emptyDB tdefs + >>= (\db' -> foldM registerDTypedefResolve db' tdefs) + >>= (\db' -> foldM registerDVar db' vars) + >>= (\db' -> foldM registerDFunc db' funcs) vars' <- mapM (annotateDVar db) vars funcs' <- mapM (annotateDFunc db) funcs - return $ Program vars' funcs' + return $ Program [] vars' funcs' + + +registerDTypedef :: TypeDB -> DTypedef -> Error TypeDB +registerDTypedef db (DTypedef n t) = case dbFind db n of + Nothing -> return $ dbSet db n (DBType t) + Just _ -> Left $ "Duplicate top-level name '" ++ n ++ "'" +registerDTypedefResolve :: TypeDB -> DTypedef -> Error TypeDB +registerDTypedefResolve db (DTypedef n t) = do + t' <- resolveType db t + return $ dbSet db n (DBType t') registerDVar :: TypeDB -> DVar -> Error TypeDB registerDVar db (DVar t n _) = case dbFind db n of - Nothing -> return $ dbSet db n (DBVar t) + Nothing -> do + t' <- resolveType db t + 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)) + Nothing -> do + rt' <- sequence $ fmap (resolveType db) rt + al' <- forM al $ \(at,an) -> (,an) <$> resolveType db at + 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 + toptype' <- resolveType db toptype 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' + 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 + " to a variable of type " ++ pretty toptype' data State = State {stDfunc :: DFunc, stLoopDepth :: Int} deriving Show annotateDFunc :: TypeDB -> DFunc -> Error DFunc annotateDFunc db dfunc@(DFunc rettype name arglist block) = do - when (name == "main" && rettype /= Just TInt) $ + rettype' <- sequence $ fmap (resolveType db) rettype + arglist' <- forM arglist $ \(at,an) -> (,an) <$> resolveType db at + when (name == "main" && rettype' /= Just TInt) $ Left $ "Function 'main' should return an int" - let db' = foldl registerArg db arglist + db' <- foldM registerArg db arglist' block' <- annotateBlock (State dfunc 0) db' block - return $ DFunc rettype name arglist block' + return $ DFunc rettype' name arglist' block' where - registerArg :: TypeDB -> (Type, Name) -> TypeDB - registerArg db' (t, n) = dbSet db' n (DBVar t) + registerArg :: TypeDB -> (Type, Name) -> Error TypeDB + registerArg db' (t, n) = dbSet db' n . DBVar <$> resolveType db' t annotateBlock :: State -> TypeDB -> Block -> Error Block annotateBlock state db (Block sts) = @@ -93,16 +119,17 @@ annotateBlock state db (Block sts) = annotateStatement :: State -> TypeDB -> Statement -> Error (TypeDB, Statement) annotateStatement _ db (SDecl toptype name expr) = do + toptype' <- resolveType db toptype 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') + 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 + " to a variable of type " ++ pretty toptype' annotateStatement _ db (SAs ae expr) = do ae' <- annotateAsExpr db ae expr' <- annotateExpr db expr @@ -182,6 +209,7 @@ 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" + Just (DBType _) -> Left $ "Cannot use type " ++ n ++ " as value in expression" annotateExpr db (ELit (LCall n as) _) = do as' <- mapM (annotateExpr db) as case dbFind db n of @@ -200,17 +228,38 @@ annotateExpr db (ELit (LCall n as) _) = do " but value of type " ++ pretty (fromJust $ typeof arg) ++ " was given" return $ ELit (LCall n as') mrt + Just (DBType t) -> case as of + [a] -> annotateExpr db (ECast t a) + _ -> Left $ "Cannot call type " ++ pretty t ++ " as function with " ++ + show (length as) ++ " arguments" annotateExpr _ (ELit lit@(LStr s) _) = return $ ELit lit (Just $ TArr TChar (Just $ fromIntegral $ length s)) +annotateExpr db (ELit (LStruct ms) _) = do + ms' <- forM ms $ \(n,e) -> (n,) <$> annotateExpr db e + types <- forM ms' $ \(n,e) -> case typeof e of + Nothing -> Left $ "Use of void value in struct literal item '" ++ n ++ "'" + Just t -> return t + return $ ELit (LStruct ms') (Just $ TStruct $ zip types (map fst ms')) annotateExpr db (ESubscript arr sub _) = do arr' <- annotateExpr db arr sub' <- annotateExpr db sub + when (isNothing (typeof sub')) $ + Left $ "Use of void value as subscripted expression" 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 (EGet st n _) = do + st' <- annotateExpr db st + case typeof st' of + Nothing -> Left $ "Use of void value as dot-indexed expression" + Just stt@(TStruct ms) -> case find ((==n) . snd) ms of + Nothing -> Left $ "Struct of type " ++ pretty stt ++ + " has no member named '" ++ n ++ "'" + Just (t, _) -> return $ EGet st' n (Just t) + Just stt -> Left $ "Use of non-struct type " ++ pretty stt ++ " as dot-indexed expression" annotateExpr db (ECast t e) = do e' <- annotateExpr db e let typ = fromJust (typeof e') @@ -232,6 +281,7 @@ 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" + Just (DBType _) -> Left $ "Cannot use type " ++ n ++ " as variable in assignment expression" annotateAsExpr db (AESubscript ae expr _) = do ae' <- annotateAsExpr db ae expr' <- annotateExpr db expr @@ -243,3 +293,14 @@ annotateAsExpr db (AESubscript ae expr _) = do TArr t _ -> return $ AESubscript ae' expr' (Just t) t -> Left $ "Indexed expression '" ++ pretty ae ++ "' has non-array type " ++ pretty t ++ " in assignment expression" + + +resolveType :: TypeDB -> Type -> Error Type +resolveType _ TInt = return TInt +resolveType _ TChar = return TChar +resolveType db (TArr t sz) = liftM (\t' -> TArr t' sz) $ resolveType db t +resolveType db (TStruct ms) = TStruct <$> mapM (\(t,n) -> liftM (,n) $ resolveType db t) ms +resolveType db (TName n) = case dbFind db n of + Nothing -> Left $ "Type name '" ++ n ++ "' not defined" + Just (DBType t) -> return t + Just _ -> Left $ "Name '" ++ n ++ "' used as type is not a type" |