diff options
Diffstat (limited to 'TypeCheck.hs')
| -rw-r--r-- | TypeCheck.hs | 33 |
1 files changed, 20 insertions, 13 deletions
diff --git a/TypeCheck.hs b/TypeCheck.hs index 36d98c8..13d33c9 100644 --- a/TypeCheck.hs +++ b/TypeCheck.hs @@ -70,24 +70,27 @@ annotateDVar db (DVar toptype name expr) = do else Left $ "Cannot assign a value of type " ++ pretty typ ++ " 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) $ Left $ "Function 'main' should return an int" let db' = foldl registerArg db arglist - block' <- annotateBlock dfunc db' block + block' <- annotateBlock (State dfunc 0) 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) = +annotateBlock :: State -> TypeDB -> Block -> Error Block +annotateBlock state db (Block sts) = Block . snd <$> foldM (\(db', l) st -> - (\(db'', st') -> (db'', l ++ [st'])) <$> annotateStatement dfunc db' st) + (\(db'', st') -> (db'', l ++ [st'])) <$> annotateStatement state db' st) (db, []) sts -annotateStatement :: DFunc -> TypeDB -> Statement -> Error (TypeDB, Statement) +annotateStatement :: State -> TypeDB -> Statement -> Error (TypeDB, Statement) annotateStatement _ db (SDecl toptype name expr) = do expr' <- annotateExpr db expr when (isNothing (typeof expr')) $ @@ -112,28 +115,32 @@ annotateStatement _ db (SAs ae expr) = do 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 +annotateStatement st 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 + bl1' <- withScope db $ flip (annotateBlock st) bl1 + bl2' <- withScope db $ flip (annotateBlock st) bl2 return (db, SIf expr' bl1' bl2') -annotateStatement dfunc db (SWhile expr bl) = do +annotateStatement (State dfunc ld) 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 + bl' <- withScope db $ flip (annotateBlock (State dfunc (ld+1))) bl return (db, SWhile expr' bl') -annotateStatement (DFunc Nothing _ _ _) db (SReturn Nothing) = +annotateStatement (State {stLoopDepth = ld}) db (SBreak n) = + if n > ld + then Left $ "'break " ++ show n ++ "' while in only " ++ show ld ++ " loops" + else return (db, SBreak n) +annotateStatement (State {stDfunc = DFunc Nothing _ _ _}) db (SReturn Nothing) = return (db, SReturn Nothing) -annotateStatement (DFunc (Just _) _ _ _) _ (SReturn Nothing) = +annotateStatement (State {stDfunc = DFunc (Just _) _ _ _}) _ (SReturn Nothing) = Left "Cannot return void value from non-void function" -annotateStatement (DFunc mrt _ _ _) db (SReturn (Just expr)) = do +annotateStatement (State {stDfunc = DFunc mrt _ _ _}) db (SReturn (Just expr)) = do expr' <- annotateExpr db expr case mrt of Nothing -> Left $ "Cannot return non-void value from void function" |