]>
Commit | Line | Data |
---|---|---|
6ade8b0a | 1 | (* L3 Compiler |
12aa4087 JW |
2 | * TypeChecker |
3 | * Author: Alex Vaynberg <alv@andrew.cmu.edu> | |
4 | * Modified: Frank Pfenning <fp@cs.cmu.edu> | |
6ade8b0a JW |
5 | * Modified: Joshua Wise <jwise> |
6 | * Modified: Chris Lu <czl> | |
12aa4087 JW |
7 | *) |
8 | ||
9 | signature TYPE_CHECK = | |
10 | sig | |
11 | (* prints error message and raises ErrorMsg.error if error found *) | |
0a24e44d | 12 | val typecheck : Ast.program -> Ast.program |
5c79bb68 | 13 | val typeof : Ast.program -> Type.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Type.vtype |
12aa4087 JW |
14 | end; |
15 | ||
16 | structure TypeChecker :> TYPE_CHECK = | |
17 | struct | |
18 | structure A = Ast | |
1144856b | 19 | structure AU = AstUtils |
5c79bb68 | 20 | structure T = Type |
1144856b JW |
21 | |
22 | fun typeof (tds, funcs) vars mark e = | |
23 | ( case e | |
24 | of A.Var a => (case Symbol.look vars a | |
25 | of NONE => (ErrorMsg.error mark ("variable `"^(Symbol.name a)^"' not declared here") ; raise ErrorMsg.Error) | |
26 | | SOME t => t) | |
e63d3705 JW |
27 | | A.Cast (ty, e') => if (T.issmall ty) andalso (T.issmall (typeof (tds, funcs) vars mark e')) |
28 | then ty | |
29 | else (ErrorMsg.error mark ("cannot cast: one of `"^(T.Print.pp_type ty)^"' or `"^(T.Print.pp_type (typeof (tds, funcs) vars mark e))^"' was not small"); raise ErrorMsg.Error) | |
5c79bb68 | 30 | | A.ConstExp _ => T.Int |
2ab9671f | 31 | | A.StringExp _ => T.String |
1144856b JW |
32 | | A.OpExp (A.EQ, [a, b]) => |
33 | (case (typeof (tds, funcs) vars mark a, typeof (tds, funcs) vars mark b) | |
5c79bb68 | 34 | of (T.Int, T.Int) => T.Int (* You shall pass! *) |
1144856b | 35 | | (a', b') => |
5c79bb68 JW |
36 | if (T.typeeq (a', T.TNull) andalso T.castable (b', T.TNull)) orelse |
37 | (T.typeeq (b', T.TNull) andalso T.castable (a', T.TNull)) orelse | |
38 | (T.typeeq (a', b')) | |
39 | then T.Int | |
40 | else (ErrorMsg.error mark ("incorrect types for equality opexp:" ^ T.Print.pp_type a' ^ ", " ^ T.Print.pp_type b') ; raise ErrorMsg.Error )) | |
1144856b JW |
41 | | A.OpExp (A.NEQ, el) => typeof (tds, funcs) vars mark (A.OpExp (A.EQ, el)) |
42 | | A.OpExp (_, el) => (List.app | |
43 | (fn e => | |
44 | (case (typeof (tds, funcs) vars mark e) | |
5c79bb68 | 45 | of T.Int => () |
1144856b | 46 | | _ => (ErrorMsg.error mark ("incorrect type for opexp; needed int") ; raise ErrorMsg.Error))) |
5c79bb68 | 47 | el ; T.Int) |
1144856b JW |
48 | | A.Marked e => typeof (tds, funcs) vars (Mark.ext e) (Mark.data e) |
49 | | A.FuncCall (i, exps) => | |
50 | let | |
51 | val func = (case Symbol.look funcs i | |
52 | of NONE => (ErrorMsg.error mark ("function `"^(Symbol.name i)^"' not declared") ; raise ErrorMsg.Error) | |
53 | | SOME f => f) | |
54 | val funcmark = AU.Function.mark func | |
55 | val (ftype, fparams) = (AU.Function.returntype func, AU.Function.params func) | |
56 | val exptypes = List.map (fn znt => typeof (tds, funcs) vars mark znt) exps | |
57 | val () = if (length exptypes = length fparams) then () | |
58 | else (ErrorMsg.error mark ("call to function `"^(Symbol.name i)^"' has incorrect parameter count [you must construct additional tycons]") ; raise ErrorMsg.Error) | |
59 | val () = List.app | |
60 | (fn (t, (i, t')) => | |
5c79bb68 | 61 | if not (T.castable (t', t)) |
1144856b JW |
62 | then (ErrorMsg.error mark ("parameter `"^(Symbol.name i)^"' in function call has wrong type [you must construct additional tycons]") ; raise ErrorMsg.Error) |
63 | else ()) | |
64 | (ListPair.zip (exptypes, fparams)) | |
65 | in | |
66 | ftype | |
67 | end | |
68 | | A.Member (e, i) => | |
69 | let | |
70 | val t = typeof (tds, funcs) vars mark e | |
71 | val name = case t | |
5c79bb68 | 72 | of (T.Typedef i) => i |
1144856b JW |
73 | | _ => (ErrorMsg.error mark ("member operation only exists for struct types") ; raise ErrorMsg.Error) |
74 | val s = case Symbol.look tds name | |
75 | of SOME s => s | |
76 | | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error) | |
5c79bb68 | 77 | val (s, smark) = (T.defdata s, T.defmark s) |
1144856b | 78 | val vl = case s |
5c79bb68 | 79 | of T.Struct vl => vl |
1144856b JW |
80 | | _ => raise ErrorMsg.InternalError "mark of marked typedef?" |
81 | val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl) | |
82 | of SOME (_, t) => t | |
83 | | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error) | |
84 | in | |
85 | t | |
86 | end | |
87 | | A.DerefMember (e, i) => | |
88 | let | |
89 | val t = typeof (tds, funcs) vars mark e | |
90 | val name = case t | |
5c79bb68 | 91 | of (T.Pointer (T.Typedef i)) => i |
1144856b JW |
92 | | _ => (ErrorMsg.error mark ("dereference and member operation only exists for struct pointer types") ; raise ErrorMsg.Error) |
93 | val s = case Symbol.look tds name | |
94 | of SOME s => s | |
95 | | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error) | |
96 | val (s, smark) = case s | |
5c79bb68 JW |
97 | of T.Struct vl => (s, NONE) |
98 | | T.MarkedTypedef m => (Mark.data m, Mark.ext m) | |
1144856b | 99 | val vl = case s |
5c79bb68 | 100 | of T.Struct vl => vl |
1144856b JW |
101 | | _ => raise ErrorMsg.InternalError "mark of marked typedef?" |
102 | val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl) | |
103 | of SOME (_, t) => t | |
104 | | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error) | |
105 | in | |
106 | t | |
107 | end | |
108 | | A.Dereference e => | |
109 | (case typeof (tds, funcs) vars mark e | |
5c79bb68 | 110 | of (T.Pointer e') => e' |
1144856b JW |
111 | | _ => (ErrorMsg.error mark ("cannot deference non-pointer type") ; raise ErrorMsg.Error)) |
112 | | A.ArrIndex (e, i) => | |
113 | (case (typeof (tds, funcs) vars mark e, typeof (tds, funcs) vars mark i) | |
5c79bb68 JW |
114 | of (T.Array e', T.Int) => e' |
115 | | (_, T.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error) | |
1144856b | 116 | | _ => (ErrorMsg.error mark ("cannot index using non-int type") ; raise ErrorMsg.Error)) |
5c79bb68 | 117 | | A.New (t) => T.Pointer t |
1144856b JW |
118 | | A.NewArr (t, s) => |
119 | (case typeof (tds, funcs) vars mark s | |
5c79bb68 | 120 | of T.Int => (T.Array t) |
1144856b | 121 | | _ => (ErrorMsg.error mark ("cannot specify non-int array dimension") ; raise ErrorMsg.Error)) |
5c79bb68 JW |
122 | | A.Null => T.TNull |
123 | | A.Conditional (q, e1, e2) => | |
124 | let | |
125 | val _ = case typeof (tds, funcs) vars mark q | |
126 | of T.Int => () | |
127 | | _ => (ErrorMsg.error mark ("ternary condition not of Int type") ; raise ErrorMsg.Error) | |
128 | val t1 = typeof (tds, funcs) vars mark e1 | |
129 | val t2 = typeof (tds, funcs) vars mark e2 | |
130 | in | |
131 | if (T.typeeq (t1, t2) orelse T.castable (t1, t2)) | |
132 | then t1 | |
133 | else if (T.castable (t2, t1)) | |
134 | then t2 | |
135 | else (ErrorMsg.error mark ("ternary types do not agree [you must construct additional tycons]") ; raise ErrorMsg.Error) | |
136 | end | |
1144856b | 137 | ) |
6ade8b0a JW |
138 | |
139 | datatype asn = ASSIGNED | UNASSIGNED | |
12aa4087 | 140 | |
1144856b JW |
141 | (* returncheck prog vars mark t l |
142 | * Determines if the statement list 'l' is guaranteed to return vtype 't'. | |
143 | * If it ever does not return vtype 't', then raises an error. | |
144 | * true if vtype 't' is always returned, or false if there is a possibility that vtype 't' will not be returned. | |
145 | *) | |
146 | fun returncheck prog vars mark t l = | |
147 | let | |
148 | fun returns' nil = false | |
149 | | returns' (A.Assign _ :: stms) = returns' stms | |
150 | | returns' (A.AsnOp _ :: stms) = returns' stms | |
151 | | returns' (A.Effect _ :: stms) = returns' stms | |
152 | | returns' (A.Return e :: stms) = | |
5c79bb68 | 153 | if (T.castable (t, typeof prog vars mark e)) |
1144856b JW |
154 | then true |
155 | else (ErrorMsg.error mark ("return value of incorrect type for function") ; raise ErrorMsg.Error) | |
156 | | returns' (A.Nop :: stms) = returns' stms | |
157 | | returns' (A.Break :: stms) = true (* blah *) | |
158 | | returns' (A.Continue :: stms) = true (* blah *) | |
159 | | returns' (A.If (_, s1, NONE) :: stms) = returns' stms | |
160 | | returns' (A.If (_, s1, SOME s2) :: stms) = (returns' s1 andalso returns' s2) orelse returns' stms | |
161 | | returns' (A.For _ :: stms) = returns' stms | |
162 | | returns' (A.While _ :: stms) = returns' stms | |
163 | | returns' (A.MarkedStm m :: stms) = returncheck prog vars (Mark.ext m) t (Mark.kane m :: stms) | |
164 | in | |
165 | returns' l | |
166 | end | |
167 | ||
168 | (* returns l | |
169 | * true iff the statement list 'l' always returns. | |
170 | *) | |
0a24e44d JW |
171 | fun returns nil = false |
172 | | returns (A.Assign _ :: stms) = returns stms | |
1144856b JW |
173 | | returns (A.AsnOp _ :: stms) = returns stms |
174 | | returns (A.Effect _ :: stms) = returns stms | |
175 | | returns (A.Return e :: stms) = true | |
0a24e44d JW |
176 | | returns (A.Nop :: stms) = returns stms |
177 | | returns (A.Break :: stms) = true (* blah *) | |
178 | | returns (A.Continue :: stms) = true (* blah *) | |
179 | | returns (A.If (_, s1, NONE) :: stms) = returns stms | |
180 | | returns (A.If (_, s1, SOME s2) :: stms) = (returns s1 andalso returns s2) orelse returns stms | |
181 | | returns (A.For _ :: stms) = returns stms | |
182 | | returns (A.While _ :: stms) = returns stms | |
6ade8b0a | 183 | | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms) |
0a24e44d | 184 | |
1144856b JW |
185 | (* breakcheck l mark |
186 | * Throws an error exception if a break or continue ever occurs in an illegal context. | |
187 | *) | |
0a24e44d JW |
188 | fun breakcheck nil mark = () |
189 | | breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ; | |
190 | raise ErrorMsg.Error ) | |
191 | | breakcheck (A.Continue :: stms) mark = ( ErrorMsg.error mark ("Illegal continue outside loop") ; | |
192 | raise ErrorMsg.Error ) | |
193 | | breakcheck (A.If (_, s1, NONE) :: stms) mark = | |
194 | ( breakcheck s1 mark; | |
195 | breakcheck stms mark) | |
196 | | breakcheck (A.If (_, s1, SOME s2) :: stms) mark = | |
197 | ( breakcheck s1 mark; | |
198 | breakcheck s2 mark; | |
199 | breakcheck stms mark) | |
6ade8b0a | 200 | | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark) |
0a24e44d JW |
201 | | breakcheck (_ :: stms) mark = breakcheck stms mark |
202 | ||
1144856b JW |
203 | (* varcheck_exp env exp mark |
204 | * Throws an error exception if a variable used in this excpression was unassigned or undefined in this context. | |
205 | *) | |
206 | fun varcheck_exp env (A.Var v) mark = | |
0a24e44d JW |
207 | ( case Symbol.look env v |
208 | of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ; | |
209 | raise ErrorMsg.Error ) | |
1144856b | 210 | | SOME UNASSIGNED => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ; |
6ade8b0a | 211 | raise ErrorMsg.Error ) |
1144856b | 212 | | SOME ASSIGNED => ()) |
e63d3705 | 213 | | varcheck_exp env (A.Cast (ty, e)) mark = varcheck_exp env e mark |
1144856b | 214 | | varcheck_exp env (A.ConstExp _) mark = () |
2ab9671f | 215 | | varcheck_exp env (A.StringExp _) mark = () |
1144856b JW |
216 | | varcheck_exp env (A.OpExp (_, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l |
217 | | varcheck_exp env (A.FuncCall (f, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l | |
218 | | varcheck_exp env (A.Marked m) mark = varcheck_exp env (Mark.kane m) (Mark.ext m) | |
219 | | varcheck_exp env (A.Member (e, i)) mark = varcheck_exp env e mark | |
220 | | varcheck_exp env (A.DerefMember (e, i)) mark = varcheck_exp env e mark | |
221 | | varcheck_exp env (A.Dereference e) mark = varcheck_exp env e mark | |
222 | | varcheck_exp env (A.ArrIndex (e1, e2)) mark = (varcheck_exp env e1 mark ; varcheck_exp env e2 mark) | |
223 | | varcheck_exp env (A.New _) mark = () | |
224 | | varcheck_exp env (A.NewArr (_, e)) mark = varcheck_exp env e mark | |
225 | | varcheck_exp env (A.Null) mark = () | |
5c79bb68 | 226 | | varcheck_exp env (A.Conditional (q, e1, e2)) mark = (varcheck_exp env q mark ; varcheck_exp env e1 mark ; varcheck_exp env e2 mark) |
0a24e44d | 227 | |
1144856b JW |
228 | (* computeassigns env exp |
229 | * Computes the assigned variables after expression exp has been executed with a starting context of env. | |
230 | *) | |
0a24e44d | 231 | fun computeassigns env nil = env |
1144856b JW |
232 | | computeassigns env (A.Assign (A.Var id,e) :: stms) = |
233 | computeassigns (Symbol.bind env (id, ASSIGNED)) stms | |
234 | | computeassigns env (A.Assign (A.Marked a, e) :: stms) = | |
235 | computeassigns env (A.Assign (Mark.data a, e) :: stms) | |
236 | | computeassigns env (A.AsnOp (oper, a, e) :: stms) = | |
237 | computeassigns env (A.Assign (a, a) :: stms) | |
238 | | computeassigns env (A.Assign (_) :: stms) = computeassigns env stms | |
239 | | computeassigns env (A.Effect _ :: stms) = computeassigns env stms | |
0a24e44d JW |
240 | | computeassigns env (A.Return _ :: stms) = env |
241 | | computeassigns env (A.Nop :: stms) = computeassigns env stms | |
242 | | computeassigns env (A.Break :: stms) = env | |
243 | | computeassigns env (A.Continue :: stms) = env | |
244 | | computeassigns env (A.If (e, s1, NONE) :: stms) = computeassigns env stms | |
245 | | computeassigns env (A.If (e, s1, SOME s2) :: stms) = | |
246 | let | |
247 | val env1 = computeassigns env s1 | |
248 | val env2 = computeassigns env s2 | |
6ade8b0a JW |
249 | val env' = |
250 | Symbol.intersect | |
1144856b JW |
251 | (fn (ASSIGNED, ASSIGNED) => ASSIGNED |
252 | | _ => UNASSIGNED) | |
6ade8b0a | 253 | (env1, env2) |
0a24e44d JW |
254 | val env' = |
255 | if (returns s1) then env2 | |
256 | else if (returns s2) then env1 | |
257 | else env' | |
258 | in | |
259 | computeassigns env' stms | |
260 | end | |
261 | | computeassigns env (A.While (e, s1) :: stms) = computeassigns env stms | |
262 | | computeassigns env (A.For (sbegin, e, sloop, inner) :: stms) = | |
263 | let | |
264 | val env' = case sbegin | |
265 | of SOME(s) => computeassigns env [s] | |
266 | | NONE => env | |
267 | in | |
268 | computeassigns env' stms | |
269 | end | |
6ade8b0a | 270 | | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms) |
0a24e44d | 271 | |
1144856b JW |
272 | (* varcheck env l mark |
273 | * Checks that all variables used in the statement list l have been defined before being used, and removes code that is unreachable according to simple return analysis. | |
274 | *) | |
275 | fun varcheck env nil mark = nil | |
276 | | varcheck env (A.Assign (A.Var id, e) :: stms) mark = | |
6ade8b0a JW |
277 | let |
278 | val sym = Symbol.look env id | |
279 | val _ = if not (isSome sym) | |
280 | then (ErrorMsg.error mark ("assignment to undeclared variable " ^ (Symbol.name id)); raise ErrorMsg.Error) | |
281 | else () | |
1144856b JW |
282 | val t = valOf sym |
283 | val _ = varcheck_exp env e mark | |
6ade8b0a | 284 | in |
1144856b | 285 | A.Assign (A.Var id, e) :: (varcheck (Symbol.bind env (id, ASSIGNED)) stms mark) |
6ade8b0a | 286 | end |
1144856b JW |
287 | | varcheck env (A.Assign (A.Marked a, e) :: stms) mark = varcheck env (A.Assign (Mark.data a, e) :: stms) mark |
288 | | varcheck env ((a as A.Assign (A.Member (e', i), e)) :: stms) mark = | |
289 | (varcheck_exp env e' mark ; | |
290 | varcheck_exp env e mark ; | |
291 | a :: varcheck env stms mark) | |
292 | | varcheck env ((a as A.Assign (A.DerefMember (e', i), e)) :: stms) mark = | |
293 | (varcheck_exp env e' mark ; | |
294 | varcheck_exp env e mark ; | |
295 | a :: varcheck env stms mark) | |
296 | | varcheck env ((a as A.Assign (A.Dereference e', e)) :: stms) mark = | |
297 | (varcheck_exp env e' mark ; | |
298 | varcheck_exp env e mark ; | |
299 | a :: varcheck env stms mark) | |
300 | | varcheck env ((a as A.Assign (A.ArrIndex (e', e''), e)) :: stms) mark = | |
301 | (varcheck_exp env e' mark ; | |
302 | varcheck_exp env e'' mark ; | |
303 | varcheck_exp env e mark ; | |
304 | a :: varcheck env stms mark) | |
305 | | varcheck env ((a as A.Assign (A.NewArr (_, e'), e)) :: stms) mark = | |
306 | (varcheck_exp env e' mark ; | |
307 | varcheck_exp env e mark ; | |
308 | a :: varcheck env stms mark) | |
309 | | varcheck env ((A.Assign _) :: stms) mark = raise ErrorMsg.InternalError "assign to non lvalue" | |
5c79bb68 | 310 | | varcheck env ((a as A.AsnOp (oper, e1, e2)) :: stms) mark = ( varcheck_exp env e1 mark ; varcheck_exp env e2 mark ; a :: varcheck env stms mark ) |
1144856b JW |
311 | | varcheck env ((a as A.Effect e) :: stms) mark = (varcheck_exp env e mark ; a :: varcheck env stms mark) |
312 | | varcheck env (A.Return (e) :: stms) mark = | |
313 | ( varcheck_exp env e mark; | |
0a24e44d | 314 | A.Return (e) :: nil ) |
1144856b JW |
315 | | varcheck env (A.Nop :: stms) mark = |
316 | ( A.Nop :: (varcheck env stms mark)) | |
317 | | varcheck env (A.Break :: stms) mark = | |
0a24e44d | 318 | ( A.Break :: nil ) |
1144856b | 319 | | varcheck env (A.Continue :: stms) mark = |
0a24e44d | 320 | ( A.Continue :: nil ) |
1144856b JW |
321 | | varcheck env (A.If (e, s1, NONE) :: stms) mark = |
322 | ( varcheck_exp env e mark ; | |
323 | varcheck env s1 mark ; | |
324 | A.If (e, s1, NONE) :: (varcheck env stms mark) ) | |
325 | | varcheck env ((i as A.If (e, s1, SOME s2)) :: stms) mark = | |
326 | ( varcheck_exp env e mark ; | |
327 | varcheck env s1 mark ; | |
328 | varcheck env s2 mark ; | |
0a24e44d JW |
329 | A.If (e, s1, SOME s2) :: |
330 | (if (returns [i]) | |
331 | then nil | |
1144856b JW |
332 | else varcheck (computeassigns env [i]) stms mark) ) |
333 | | varcheck env (A.While (e, s1) :: stms) mark = | |
334 | ( varcheck_exp env e mark ; | |
335 | varcheck env s1 mark ; | |
336 | A.While (e, s1) :: (varcheck env stms mark) ) | |
337 | | varcheck env (A.For (sbegin, e, sloop, inner) :: stms) mark = | |
0a24e44d JW |
338 | let |
339 | val sbegin = case sbegin | |
1144856b | 340 | of SOME(s) => SOME (hd (varcheck env [s] mark)) |
0a24e44d JW |
341 | | NONE => NONE |
342 | val env' = case sbegin | |
343 | of SOME(s) => computeassigns env [s] | |
344 | | NONE => env | |
5c79bb68 | 345 | val _ = varcheck_exp env' e mark |
1144856b | 346 | val inner = varcheck env' inner mark |
0a24e44d JW |
347 | val env'' = computeassigns env' inner |
348 | val sloop = case sloop | |
1144856b | 349 | of SOME(s) => SOME (hd (varcheck env'' [s] mark)) |
0a24e44d JW |
350 | | NONE => NONE |
351 | in | |
1144856b | 352 | A.For (sbegin, e, sloop, inner) :: (varcheck env' stms mark) |
0a24e44d | 353 | end |
1144856b | 354 | | varcheck env (A.MarkedStm m :: stms) mark = varcheck env ((Mark.kane m) :: stms) (Mark.ext m) |
12aa4087 | 355 | |
1144856b JW |
356 | fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,stat)) sym l |
357 | fun bindtypes sym l = foldr (fn ((i,t), s) => Symbol.bind s (i,t)) sym l | |
6ade8b0a | 358 | |
1144856b | 359 | fun dupchk mark l src = |
6ade8b0a JW |
360 | List.app |
361 | (fn (n, _) => | |
362 | let | |
363 | val name = Symbol.name n | |
364 | val all = List.filter (fn (n', _) => name = (Symbol.name n')) l | |
365 | val count = length all | |
366 | in | |
367 | if count = 1 | |
368 | then () | |
1144856b | 369 | else ( ErrorMsg.error mark ("multiple definition of variable " ^ (Symbol.name n) ^ " in " ^ src); |
6ade8b0a JW |
370 | raise ErrorMsg.Error ) |
371 | end) l | |
1144856b JW |
372 | |
373 | fun check_lvalue prog vars mark (A.Marked m) = check_lvalue prog vars (Mark.ext m) (Mark.data m) | |
374 | | check_lvalue prog vars mark (e as A.Var _) = typeof prog vars mark e | |
375 | | check_lvalue prog vars mark (e as A.Member _) = typeof prog vars mark e | |
376 | | check_lvalue prog vars mark (e as A.DerefMember _) = typeof prog vars mark e | |
377 | | check_lvalue prog vars mark (e as A.Dereference _) = typeof prog vars mark e | |
378 | | check_lvalue prog vars mark (e as A.ArrIndex _) = typeof prog vars mark e | |
379 | | check_lvalue prog vars mark _ = ( ErrorMsg.error mark ("invalid lvalue") ; raise ErrorMsg.Error ) | |
380 | fun typecheck_stm prog vars mark stm = | |
381 | case stm | |
382 | of A.Assign (e1, e2) => | |
5c79bb68 | 383 | if not (T.castable (check_lvalue prog vars mark e1, typeof prog vars mark e2)) |
1144856b | 384 | then (ErrorMsg.error mark "incompatible types in assignment" ; raise ErrorMsg.Error ) |
5c79bb68 | 385 | else if not (T.issmall (check_lvalue prog vars mark e1)) |
1144856b JW |
386 | then (ErrorMsg.error mark "lvalue is not small" ; raise ErrorMsg.Error) |
387 | else () | |
388 | | A.AsnOp (oper, e1, e2) => typecheck_stm prog vars mark (A.Assign (e1, A.OpExp (oper, [e1, e2]))) | |
389 | | A.Effect e => | |
5c79bb68 | 390 | if not (T.issmall (typeof prog vars mark e)) |
1144856b JW |
391 | then (ErrorMsg.error mark "simple statement's value not small" ; raise ErrorMsg.Error ) |
392 | else () | |
393 | | A.Return e => (typeof prog vars mark e ; ()) | |
394 | | A.Nop => () | |
395 | | A.Break => () | |
396 | | A.Continue => () | |
397 | | A.If (e, s, NONE) => | |
5c79bb68 | 398 | if T.castable (T.Int, typeof prog vars mark e) |
1144856b JW |
399 | then (List.app (typecheck_stm prog vars mark) s) |
400 | else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error ) | |
401 | | A.If (e, s1, SOME s2) => | |
5c79bb68 | 402 | if T.castable (T.Int, typeof prog vars mark e) |
1144856b JW |
403 | then (List.app (typecheck_stm prog vars mark) s1 ; List.app (typecheck_stm prog vars mark) s2) |
404 | else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error ) | |
405 | | A.For (sbegin, e, sloop, s) => | |
5c79bb68 | 406 | if T.castable (T.Int, typeof prog vars mark e) |
1144856b JW |
407 | then (List.app (typecheck_stm prog vars mark) ((case sbegin of SOME l => [l] | NONE => nil) @ (case sloop of SOME l => [l] | NONE => nil) @ s)) |
408 | else (ErrorMsg.error mark "conditional in for statement is not of int type" ; raise ErrorMsg.Error ) | |
409 | | A.While (e, s) => | |
5c79bb68 | 410 | if T.castable (T.Int, typeof prog vars mark e) |
1144856b JW |
411 | then (List.app (typecheck_stm prog vars mark) s) |
412 | else (ErrorMsg.error mark "conditional in while statement is not of int type" ; raise ErrorMsg.Error ) | |
413 | | A.MarkedStm (m) => typecheck_stm prog vars (Mark.ext m) (Mark.data m) | |
414 | ||
415 | (* XXX does not check big vs. small types *) | |
5c79bb68 | 416 | fun typecheck_type (tds, funcs) mark T.Int = () |
2ab9671f | 417 | | typecheck_type (tds, funcs) mark T.String = () |
5c79bb68 JW |
418 | | typecheck_type (tds, funcs) mark T.TNull = () |
419 | | typecheck_type (tds, funcs) mark (T.Pointer t) = typecheck_type (tds, funcs) mark t | |
420 | | typecheck_type (tds, funcs) mark (T.Array t) = typecheck_type (tds, funcs) mark t | |
421 | | typecheck_type (tds, funcs) mark (T.Typedef t) = | |
1144856b JW |
422 | case (Symbol.look tds t) |
423 | of SOME _ => () | |
424 | | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name t)^"' does not exist") ; raise ErrorMsg.Error) | |
6ade8b0a | 425 | |
1144856b JW |
426 | fun typecheck_fn prog _ (id, A.MarkedFunction m) = typecheck_fn prog (Mark.ext m) (id, Mark.data m) |
427 | | typecheck_fn (prog as (tds, funcs)) mark (id, A.Extern (t, al)) = | |
5c79bb68 | 428 | (if (String.isPrefix "_l5_" (Symbol.name id)) |
1144856b JW |
429 | then |
430 | let | |
431 | val n = String.extract (Symbol.name id, 4, NONE) | |
432 | in | |
433 | if List.exists (fn (id, f) => case (AU.Function.data f) of A.Function _ => (Symbol.name id = n) | _ => false) (Symbol.elemsi funcs) | |
434 | then (ErrorMsg.error mark ("you anus, extern " ^ Symbol.name id ^ " conflicts with local function"); raise ErrorMsg.Error) | |
435 | else () | |
436 | end | |
437 | else () ; | |
438 | dupchk mark al ; | |
439 | List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) al) ; | |
440 | A.Extern (t, al)) | |
441 | | typecheck_fn prog mark (id, A.Function (t, al, vl, sl)) = | |
6ade8b0a | 442 | let |
1144856b JW |
443 | val () = dupchk mark (al @ vl) ("function `"^Symbol.name id^"'") (* Before we do any bindings, check for duplicate names. *) |
444 | val () = List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) (al @ vl)) | |
6ade8b0a JW |
445 | val env = Symbol.empty |
446 | val env = bindvars env ASSIGNED al | |
447 | val env = bindvars env UNASSIGNED vl | |
1144856b JW |
448 | val vars = Symbol.empty |
449 | val vars = bindtypes vars al | |
450 | val vars = bindtypes vars vl | |
451 | val () = breakcheck sl mark | |
452 | val () = if not (returncheck prog vars NONE t sl) | |
453 | then ( ErrorMsg.error mark ("function `"^ Symbol.name id ^ "' does not return in all cases"); | |
454 | raise ErrorMsg.Error ) | |
455 | else () | |
456 | val () = List.app ( | |
457 | fn (n, t) => | |
5c79bb68 | 458 | if (T.issmall t) |
1144856b JW |
459 | then () |
460 | else ( ErrorMsg.error mark ("variable `"^(Symbol.name n)^"' in function `"^(Symbol.name id)^"' not small") ; raise ErrorMsg.Error)) | |
461 | (al @ vl) | |
462 | val () = List.app (typecheck_stm prog vars mark) sl | |
6ade8b0a | 463 | in |
1144856b | 464 | A.Function (t, al, vl, varcheck env sl NONE) |
6ade8b0a | 465 | end |
1144856b JW |
466 | |
467 | structure SymbolSet = ListSetFn ( | |
468 | struct | |
469 | type ord_key = Symbol.symbol | |
470 | val compare = Symbol.compare | |
471 | end | |
472 | ) | |
473 | ||
474 | fun typecheck_structs (prog as (tds, funcs)) = | |
475 | let | |
476 | exception Yuq | |
477 | ||
478 | val all = SymbolSet.addList (SymbolSet.empty, Symbol.keys tds) | |
479 | fun lookup mark sym = | |
480 | let | |
481 | val s = case Symbol.look tds sym | |
482 | of SOME a => a | |
483 | | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name sym)^"' does not exist") ; raise ErrorMsg.Error) | |
5c79bb68 JW |
484 | val vl = case T.defdata s |
485 | of T.Struct vl => vl | |
486 | | T.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type" | |
1144856b | 487 | in |
5c79bb68 | 488 | (vl, T.defmark s) |
1144856b JW |
489 | end |
490 | fun checksym mark sym stack k remaining = | |
491 | if not (SymbolSet.member (remaining, sym)) | |
492 | then k remaining | |
493 | else if (SymbolSet.member (stack, sym)) | |
494 | then ( ErrorMsg.error mark ("structure `"^ (Symbol.name sym) ^"' is involved in a recursive mess") ; raise Yuq) | |
495 | else | |
496 | let | |
497 | val stack' = SymbolSet.add (stack, sym) | |
498 | val (vl, mark') = lookup mark sym | |
499 | val () = dupchk mark vl ("structure `"^(Symbol.name sym)^"'") | |
500 | fun remove k remaining' = k (SymbolSet.delete (remaining', sym)) | |
501 | val newk = (* OH GOD D: *) | |
502 | foldr | |
5c79bb68 | 503 | (fn ((_, T.Typedef s), k') => checksym mark' s stack' k' |
1144856b JW |
504 | | (_, k') => k') |
505 | (remove k) | |
506 | vl | |
507 | in | |
508 | newk remaining handle Yuq => (ErrorMsg.error mark' ("from structure `"^(Symbol.name sym)^"'") ; raise Yuq) | |
509 | end | |
510 | fun chooseone k set = | |
511 | case (SymbolSet.listItems set) | |
512 | of nil => k set | |
513 | | (h::l) => checksym NONE h SymbolSet.empty (chooseone k) set | |
514 | in | |
515 | chooseone (fn _ => ()) all handle Yuq => raise ErrorMsg.Error | |
516 | end | |
6ade8b0a | 517 | |
1144856b | 518 | fun typecheck (tds, funcs) = |
6ade8b0a | 519 | let |
1144856b | 520 | val main = case (Symbol.look funcs (Symbol.symbol "main")) |
6ade8b0a JW |
521 | of NONE => ( ErrorMsg.error NONE ("no function named main"); |
522 | raise ErrorMsg.Error ) | |
523 | | SOME m => m | |
1144856b | 524 | val (main, mainp) = (AU.Function.data main, AU.Function.mark main) |
6ade8b0a | 525 | val () = case main |
1144856b | 526 | of A.Extern _ => ( ErrorMsg.error mainp ("you anus, main can't be an extern"); |
6ade8b0a | 527 | raise ErrorMsg.Error ) |
5c79bb68 JW |
528 | | A.Function (T.Int, nil, _, _) => () |
529 | | A.Function (T.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters"); | |
6ade8b0a | 530 | raise ErrorMsg.Error ) |
1144856b JW |
531 | | A.Function (_, _, _, _) => ( ErrorMsg.error mainp ("main has incorrect return type"); |
532 | raise ErrorMsg.Error ) | |
533 | | _ => raise ErrorMsg.InternalError "marked of marked disallowed" | |
534 | val () = typecheck_structs (tds, funcs) | |
6ade8b0a | 535 | in |
1144856b | 536 | (tds, Symbol.mapi (typecheck_fn (tds, funcs) NONE) funcs) |
6ade8b0a | 537 | end |
12aa4087 | 538 | end |