aboutsummaryrefslogtreecommitdiff
path: root/TypeCheck.hs
blob: 36d98c8bbb4a6ae33b4406efbc2688dc2b428795 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
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"