-
Notifications
You must be signed in to change notification settings - Fork 0
/
semant.ml
508 lines (470 loc) · 20.9 KB
/
semant.ml
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
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
(* Semantic checking for the RJEC compiler
* Initially based on MicroC, with inspiration from Shoo
* Written by Elaine Wang, Justin Chen, Riya Chakraborty, and Caroline Hoang
*)
open Ast
open Sast
module StringMap = Map.Make(String)
(* Semantic checking of the AST. Returns an SAST if successful,
throws an exception if something is wrong.
Check each global variable, then check each function *)
let check (globals, (functions, structs)) =
let vdecl_typ_to_typ : vdecl_typ -> typ = function
Int -> Int
| Bool -> Bool
| Char -> Char
| Chan(t) -> Chan(t)
| ArrayInit(_, t) -> Array(t)
| Struct(s) -> Struct(s)
in
let typ_to_vdecl_typ : typ -> vdecl_typ = function
Int -> Int
| Bool -> Bool
| Char -> Char
| Chan(t) -> Chan(t)
| Array(_) -> raise (Failure("array not implemented"))
| Struct(s) -> Struct(s)
in
let default_vals_in_sexpr : typ -> typ * sx = function
Int -> (Int, SIntLit 0)
| Bool -> (Bool, SBoolLit false)
| Char -> (Char, SCharLit 0)
| _ -> raise(Failure("composite types have to be checked separately for their default values"))
in
let flatten_global global = List.map
(fun name -> (vdecl_typ_to_typ (fst global), name)) (snd global)
in
(* Add global names to symbol table *)
let add_global map vd =
let dup_err = "duplicate global " ^ snd vd
and make_err er = raise (Failure er)
and n = snd vd
and typ = fst vd
in match n with (* No duplicate globals *)
| _ when StringMap.mem n map -> make_err dup_err
| _ -> StringMap.add n typ map
in
let check_global map global =
List.fold_left add_global map (flatten_global global)
in
let global_decls = List.fold_left check_global StringMap.empty globals
in
(* Verify a list of bindings has no duplicate names *)
let check_binds (kind : string) (binds : bind list) =
let rec dups = function
[] -> ()
| ((_,n1) :: (_,n2) :: _) when n1 = n2 ->
raise (Failure ("duplicate " ^ kind ^ " " ^ n1))
| _ :: t -> dups t
in dups (List.sort (fun (_,a) (_,b) -> compare a b) binds)
in
(* Add structs to symbol table *)
let add_struct smap sd =
let dup_err = "duplicate struct " ^ (fst sd)
and make_err er = raise (Failure er)
and n = fst sd
in match n with (* No duplicate globals *)
| _ when StringMap.mem n smap -> make_err dup_err
| _ -> check_binds ("member in definition of struct " ^ (fst sd) ^ " :") (snd sd);
let members = List.fold_left (fun m (t, n) -> StringMap.add n t m) StringMap.empty (snd sd) in
StringMap.add n members smap
in
let struct_decls = List.fold_left add_struct StringMap.empty structs
in
(**** Check functions ****)
(* Collect function declarations for built-in functions: no bodies *)
let built_in_decls =
let add_bind map (name, ty) = StringMap.add name {
types = [];
fname = name;
formals = [(ty, "x")];
body = [] } map
in
let print_decls = List.fold_left add_bind StringMap.empty [ ("printi", Int);
("printb", Bool);
("printc", Char);
("prints", Array(Char)) ]
in StringMap.add "time" {
types = [Int];
fname = "time";
formals = [];
body = [] } print_decls
in
(* Add function name to symbol table *)
let add_func map fd =
let built_in_err = "built-in function " ^ fd.fname ^ " is already defined"
and dup_err = "duplicate function " ^ fd.fname
and make_err er = raise (Failure er)
and n = fd.fname (* Name of the function *)
in match fd with (* No duplicate functions or redefinitions of built-ins *)
_ when StringMap.mem n built_in_decls -> make_err built_in_err
| _ when StringMap.mem n map -> make_err dup_err
| _ -> StringMap.add n fd map
in
(* Collect all function names into one symbol table *)
let function_decls = List.fold_left add_func built_in_decls functions
in
(* Return a function from our symbol table *)
let find_func s =
try StringMap.find s function_decls
with Not_found -> raise (Failure ("unrecognized function " ^ s))
in
let find_struct s =
try StringMap.find s struct_decls
with Not_found -> raise (Failure ("unrecognized struct " ^ s))
in
let _ = find_func "main" in (* Ensure "main" is defined *)
let check_function func =
(* Make sure no formals or locals are duplicates *)
check_binds "formal" func.formals;
(* Raise an exception if the given rvalue type cannot be assigned to
the given lvalue type *)
let check_assign lvaluet rvaluet err =
if lvaluet = rvaluet then lvaluet else raise (Failure err)
in
let add_to_scope (v_type : typ) (v_name : string)
(scope : typ StringMap.t list) =
let map = List.hd scope in
try
match (StringMap.find v_name map) with
_ -> raise (Failure ("local variable " ^ v_name ^ " has already been declared"))
with Not_found ->
let newMap = StringMap.add v_name v_type map in
newMap::List.tl scope
in
let create_scope list =
let rec helper m = function
[] -> m
| (t, n)::tl ->
let new_m = StringMap.add n t m in
helper new_m tl
in helper StringMap.empty list
in
let scope = [ create_scope func.formals; global_decls ]
in
(* Return a variable from our local symbol table *)
let rec type_of_identifier (v_name : string) (scope : typ StringMap.t list) =
try
StringMap.find v_name (List.hd scope)
with Not_found -> match List.tl scope with
[] -> raise (Failure("undeclared reference " ^ v_name))
| tail -> type_of_identifier v_name tail
in
let check_chan : typ -> typ = function
Chan(t) -> t
| _ -> raise(Failure("tried to perform channel operation through a non-channel variable"))
in
let rec vdecl_to_svdecl_typ (t: vdecl_typ) (scope: _) : svdecl_typ = match t with
Int -> SInt
| Bool -> SBool
| Char -> SChar
| Chan(t) -> SChan(vdecl_to_svdecl_typ (typ_to_vdecl_typ t) scope)
| Struct(s) -> SStruct(s)
| ArrayInit(e, t) ->
let (t', e') = expr scope e in
if t' <> Int then raise(Failure("array size can only be integer expressions"));
SArrayInit(vdecl_to_svdecl_typ (typ_to_vdecl_typ t) scope, (t', e'))
and
(* Return a semantically-checked expression, i.e., with a type *)
expr (scope : typ StringMap.t list) (e : expr) : sexpr = match e with
IntLit l -> (Int, SIntLit l)
| StrLit l -> (Array(Char), SStrLit l)
| CharLit l -> (Char, SCharLit l)
| BoolLit l -> (Bool, SBoolLit l)
| ArrLit(t, el) ->
let check_elem e =
let (t', e') = expr scope e in
if t' <> t then raise(Failure("array element doesn't match declared array type"));
(t', e')
in
let selems = List.map check_elem el in
(Array(t), SArrLit(t, selems))
| StructLit(sn, ml) ->
let smembers = find_struct sn in
let check_member sname members vm (n, e) =
let (t, e') = expr scope e in
match n with
_ when ((StringMap.mem n members) && (t = StringMap.find n members)) -> StringMap.add n (t, e') vm
| _ -> raise(Failure("unknown member " ^ n ^ " of type " ^ (string_of_typ t)
^ " in definition of struct " ^ sname)) in
let member_vals = List.fold_left (check_member sn smembers) StringMap.empty ml in
let full_member_vals = List.fold_left (fun m (n, t) -> match n with
_ when StringMap.mem n m -> m
| _ -> StringMap.add n (default_vals_in_sexpr t) m
) member_vals (StringMap.bindings smembers) in
(Struct(sn), SStructLit(sn, StringMap.bindings full_member_vals))
| Id s -> (type_of_identifier s scope, SId s)
| Unop(op, e) as ex ->
let (t, e') = expr scope e in
let ty = match op with
Neg when t = Int -> t
| Not when t = Bool -> Bool
| _ -> raise (Failure ("illegal unary operator " ^
string_of_uop op ^ string_of_typ t ^
" in " ^ string_of_expr ex))
in (ty, SUnop(op, (t, e')))
| Binop(e1, op, e2) as e ->
let (t1, e1') = expr scope e1
and (t2, e2') = expr scope e2 in
(* All binary operators require operands of the same type *)
let same = t1 = t2 in
(* Determine expression type based on operator and operand types *)
let ty : typ = match op with
Add | Sub | Mult | Div | Mod when same && t1 = Int -> Int
| Equal when same && (t1 = Int || t1 = Char || t1 = Bool) -> Bool
| Less | Leq
when same && (t1 = Int || t1 = Char) -> Bool
| And | Or when same && t1 = Bool -> Bool
| _ -> raise (
Failure ("illegal binary operator " ^
string_of_typ t1 ^ " " ^ string_of_op op ^ " " ^
string_of_typ t2 ^ " in " ^ string_of_expr e))
in (ty, SBinop((t1, e1'), op, (t2, e2')))
| Make(t, buf_raw) ->
let check_buf (buf_raw : expr option) : sexpr = match buf_raw with
None -> (Int, SIntLit 0)
| Some(e) -> let (t', e') = expr scope e in
if t' <> Int then raise(Failure("non-integer used for channel buffer size"))
else (t', e') in
let buf = check_buf buf_raw in
(Chan(t), SMake(t, buf))
| Send(n, e) ->
let (ct, ce) = expr scope n in
let chan_type = check_chan ct in
let (t', e') = expr scope e in
if t' <> chan_type then raise(Failure("Channel type mismatch with type of element to send"));
(t', SSend((ct, ce), (t', e')))
| Recv n ->
let (ct, ce) = expr scope n in
let chan_type = check_chan ct in
(chan_type, SRecv((ct, ce), chan_type))
| Close n ->
let (ct, ce) = expr scope n in
let chan_type = check_chan ct in
(chan_type, SClose((ct, ce), chan_type))
| Access(e, mn) ->
let e' = expr scope e in
let extract_struct_name (t : typ) = match t with
Struct(n) -> n
| _ -> raise(Failure("Invalid syntax: access member field of non-struct object\n")) in
let check_struct_or_arr_field e' = match (snd e') with
SId(n) -> extract_struct_name (type_of_identifier n scope)
| SSubscript(an, _) -> (function
Array(Struct(n)) -> n
| _ -> raise(Failure("subscript on non-struct array element!"))
) (type_of_identifier an scope)
| _ -> raise(Failure("invalid access; should've checked in semant!")) in
let sn = check_struct_or_arr_field e' in
let smembers = find_struct sn in
let t = match sn with
_ when StringMap.mem mn smembers -> StringMap.find mn smembers
| _ -> raise(Failure("unknown field " ^ mn ^ " in struct " ^ sn)) in
(t, SAccess((snd e'), sn, mn))
| Subscript(s, e) ->
let arr = expr scope (Id s) in
let array_t = (function
Array(t) -> t
| _ -> raise(Failure("using subscript on non-array object!"))) (fst arr) in
let index = expr scope e in
if (fst index) <> Int then raise(Failure("subscript with non-integer expression!"));
(array_t, SSubscript(s, index))
| Call(fname, args) as call ->
let fd = find_func fname in
let param_length = List.length fd.formals in
if List.length args != param_length then
raise (Failure ("expecting " ^ string_of_int param_length ^
" arguments in " ^ string_of_expr call))
else let check_call (ft, _) e =
let (et, e') = expr scope e in
let err = "illegal argument found " ^ string_of_typ et ^
" expected " ^ string_of_typ ft ^ " in " ^ string_of_expr e
in (check_assign ft et err, e')
in
let args' = List.map2 check_call fd.formals args in
(* fix multiple returns later *)
let rt_type : typ = match fd.types with
[] -> Int
| t :: [] -> t
| _ -> raise(Failure("Multiple return types not implemented yet")) in
(rt_type, SCall(fname, args'))
| _ -> raise (Failure ("not yet implemented"))
in
let check_assign_var scope var e =
let lt = type_of_identifier var scope and (rt, e') = expr scope e in
let err = "illegal assignment " ^ string_of_typ lt ^ " = " ^
string_of_typ rt
in ignore(check_assign lt rt err); (var, (rt, e'))
in
let check_bool_expr scope e =
let (t', e') = expr scope e
and err = "expected Boolean expression in " ^ string_of_expr e
in if t' != Bool then raise (Failure err) else (t', e')
in
(* Return a semantically-checked statement i.e. containing sexprs *)
let rec check_stmt scope = function
Expr e -> (SExpr(expr scope e), scope)
| If(p, b1, b2) ->
let (sstmt1, _) = check_stmt scope b1
and (sstmt2, _) = check_stmt scope b2 in
(SIf(check_bool_expr scope p, sstmt1, sstmt2), scope)
| For(e1, e2, e3, st) ->
let rec forbid_defer = function
Defer _ -> raise(Failure("defer statement inside of while block"))
| Block sl -> List.iter forbid_defer sl
| _ -> () in
forbid_defer st;
let (sstmt, nscope) =
(function
None -> (SExpr(Int, SNoexpr), scope)
| Some(s) -> check_stmt scope (AssignStmt s)
) e1 in
let sexpr = check_bool_expr nscope e2 in
let (sstmt3, nscope) = (fun scope e -> match e with
Some(Assign(_, _) as e') -> check_stmt scope (AssignStmt e')
| None -> (SExpr(Int, SNoexpr), scope)
| _ -> raise(Failure("variable declaration misplaced in for loop"))
) nscope e3 in
let (sstmt4, _) = check_stmt nscope st in
(SFor(sstmt, sexpr, sstmt3, sstmt4), scope)
| While(e, s) ->
let rec forbid_defer = function
Defer _ -> raise(Failure("defer statement inside of while block"))
| Block sl -> List.iter forbid_defer sl
| _ -> () in
forbid_defer s;
let (sstmt, nscope) = check_stmt scope s in
(SWhile(check_bool_expr nscope e, sstmt), nscope)
| Return el ->
if (List.length el <> List.length func.types) then
raise(Failure("The function '" ^ func.fname ^ "' has " ^
string_of_int (List.length func.types) ^
" return types, but only " ^ string_of_int (List.length el) ^
" expressions were returned"));
let check_return_typ e rt =
let (t, e') = expr scope e in
if t = rt then (t, e')
else raise (Failure ("return gives " ^ string_of_typ t ^ " expected " ^
string_of_typ rt ^ " in " ^ string_of_expr e))
in
(SReturn(List.map2 check_return_typ el func.types), scope)
(* A block is correct if each statement is correct and nothing
follows any Return statement. Nested blocks are flattened. *)
| Yeet e ->
let scall = (function
Call(f, _) as call ->
let fdecl = find_func f in
if (fdecl.types <> []) && (fdecl.types <> [Int])
then raise(Failure("a yeet function call can only return int or nothing"));
snd (expr scope call)
| _ -> raise(Failure("can't yeet a non-function call"))
) e in (SYeet(scall), scope)
| AssignStmt s ->
let check_assign_stmt = function
Assign(vl, el) ->
let helper v e =
let (mt, e') = expr scope v in
(function
SId s ->
let (_, e') = check_assign_var scope s e in
((fst e', SId(s)), e')
| SAccess (n, sn, mn) ->
let (t, e') = expr scope e in
if mt <> t then raise(Failure("illegal assignment " ^ string_of_typ mt ^ " = " ^
string_of_typ t)); ((mt, SAccess(n, sn, mn)) , (t, e'))
| SSubscript (an, index) ->
let mt = type_of_identifier an scope in
let (t, e') = expr scope e in
if mt <> Array(t) then raise(Failure("illegal assignment of element to array"));
((mt, SSubscript(an, index)), (t, e'))
| _ -> raise(Failure("invalid assignment"))
) e'
in
(SAssign (List.map2 helper vl el), scope)
| DeclAssign(vd, el) -> let (_, nscope) = check_stmt scope (VdeclStmt vd) in
let vdl = List.map (fun n -> (n, vdecl_to_svdecl_typ (fst vd) scope) ) (snd vd) in
let assl = List.map2 (check_assign_var nscope) (snd vd) el in
(SDeclAssign(vdl, assl), nscope)
| Init(vl, el) ->
let helper (ll, scope) v e =
let s = (function
Id s -> s
| _ -> raise(Failure("trying to initialize non-identifier"))
) v in
let (t, e') = expr scope e in
let nscope = add_to_scope t s scope in
let lhs_svdecl = (function
(_, SArrLit(elem_t, el)) ->
let arr_len = List.length el in
SArrayInit(
vdecl_to_svdecl_typ (typ_to_vdecl_typ elem_t) scope,
(Int, SIntLit(arr_len))
)
| (_, SStrLit l) -> SArrayInit(SChar, (Int, SIntLit((String.length l) + 1)))
| (Array(elem_t), _) -> SArrayInit(
vdecl_to_svdecl_typ (typ_to_vdecl_typ elem_t) scope,
(Int, SIntLit(1))
)
| _ -> vdecl_to_svdecl_typ (typ_to_vdecl_typ t) scope
) (t, e')
in
(SDeclAssign([(s, lhs_svdecl)], [(s, (t, e'))]) :: ll,
nscope)
in
let (dal, nscope) = List.fold_left2 helper ([], scope) vl el
in (SInit(List.rev dal), nscope)
in let (sassign, sscope) = check_assign_stmt s in
(SAssignStmt(sassign), sscope)
| VdeclStmt s ->
let (t, nl) = s in
let (nscope, vdecls) = List.fold_left (fun (scope, vdecls) n ->
(add_to_scope (vdecl_typ_to_typ t) n scope, (n, vdecl_to_svdecl_typ t scope)::vdecls)
) (scope, []) nl
in (SVdeclStmt(vdecls), nscope)
| Defer e ->
(function
Call(_, _) -> (SDefer(expr scope e), scope)
| _ -> raise(Failure("defering a non-function call"))
) e
| Select cl ->
let rec check_case_list scope = function
(case, sl) :: tl ->
let case_instr = (function
Expr(Send(c, e)) -> SSend(expr scope c, expr scope e)
| Expr(Recv(c)) | AssignStmt(DeclAssign(_, [Recv(c)]))
| AssignStmt(Assign(_, [Recv(c)]))
| AssignStmt(Init(_, [Recv(c)])) ->
let (ct, ce) = expr scope c in
let chan_type = check_chan ct in
SRecv((ct, ce), chan_type)
| _ -> raise(Failure("wrong case format in semant"))
) case in
let blockstmt = Block(case :: sl) in
let (ret, _) = check_stmt scope blockstmt in
let ret2 = check_case_list scope tl in
((case_instr, ret) :: ret2)
| [] -> []
in
(SSelect(check_case_list scope cl), scope)
| Block sl ->
let bscope = (create_scope []) :: scope in
let rec check_stmt_list scope = function
[Return _ as s] ->
let (ret, _) = check_stmt scope s in ([ret], scope)
| Return _ :: _ -> raise (Failure "nothing may follow a return")
| s :: ss ->
let (ret, nscope) = check_stmt scope s in
let (ret2, nscope2) = check_stmt_list nscope ss in
(ret :: ret2, nscope2)
| [] -> ([], scope)
in let (bret, _) = check_stmt_list bscope sl
in (SBlock(bret), scope)
in (* body of check_function *)
{ stypes = func.types;
sfname = func.fname;
sformals = func.formals;
sbody = match check_stmt scope (Block func.body) with
(SBlock(sl), _) -> sl
| _ -> raise (Failure ("internal error: block didn't become a block?"))
}
in (List.flatten (List.map flatten_global globals),
List.map check_function functions, structs)