comparison lab4/check.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 (* lab4/check.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Optree
5 open Tree
6 open Dict
7 open Print
8 open Lexer
9 open Mach
10
11 (* EXPRESSIONS *)
12
13 (* A few global variables to save passing parameters everywhere *)
14
15 (* Nesting level of current procedure *)
16 let level = ref 0
17
18 (* Return type of current procedure *)
19 let return_type = ref voidtype
20
21 (* Whether to allocate register variables *)
22 let regvars = ref true
23
24 (* Line number to use when reporting errors *)
25 let err_line = ref 1
26
27 (* Exception raised when a semantic error is detected *)
28 exception Sem_error of string * Print.arg list * int
29
30 (* |sem_error| -- report a semantic error and abandon analysis *)
31 let sem_error fmt args =
32 raise (Sem_error (fmt, args, !err_line))
33
34 (* |expr_fail| -- report type error in most unhelpful way possible *)
35 let expr_fail () = sem_error "type error in expression" []
36
37 (* |lookup_def| -- find definition of a name, give error if none *)
38 let lookup_def x env =
39 err_line := x.x_line;
40 try
41 let d = lookup x.x_name env in
42 x.x_def <- Some d; d
43 with Not_found ->
44 sem_error "$ is not declared" [fId x.x_name]
45
46 (* |add_def| -- add definition to envmt, give error if already declared *)
47 let add_def d env =
48 try define d env with
49 Exit -> sem_error "$ is already declared" [fId d.d_tag]
50
51 (* |check_monop| -- check application of unary operator *)
52 let check_monop w t =
53 match w with
54 Uminus ->
55 if not (same_type t integer) then expr_fail ();
56 integer
57 | Not ->
58 if not (same_type t boolean) then expr_fail ();
59 boolean
60 | _ -> failwith "bad monop"
61
62 (* |check_binop| -- check application of binary operator *)
63 let check_binop w t1 t2 =
64 match w with
65 Plus | Minus | Times | Div | Mod ->
66 if not (same_type t1 integer && same_type t2 integer) then
67 expr_fail ();
68 integer
69 | Eq | Lt | Gt | Leq | Geq | Neq ->
70 if not (scalar t1) || not (same_type t1 t2) then expr_fail ();
71 boolean
72 | And | Or ->
73 if not (same_type t1 boolean && same_type t2 boolean) then
74 expr_fail ();
75 boolean
76 | _ -> failwith "bad binop"
77
78 (* |try_monop| -- propagate constant through unary operation *)
79 let try_monop w =
80 function
81 Some x -> Some (do_monop w x)
82 | None -> None
83
84 (* |try_binop| -- propagate constant through unary operation *)
85 let try_binop w v1 v2 =
86 match (v1, v2) with
87 (Some x1, Some x2) -> Some (do_binop w x1 x2)
88 | _ -> None
89
90 (* |has_value| -- check if object is suitable for use in expressions *)
91 let has_value d =
92 match d.d_kind with
93 ConstDef _ | VarDef | CParamDef | VParamDef | StringDef -> true
94 | _ -> false
95
96 (* |check_var| -- check that expression denotes a variable *)
97 let rec check_var e addressible =
98 match e.e_guts with
99 Variable x ->
100 let d = get_def x in
101 begin
102 match d.d_kind with
103 VarDef | VParamDef | CParamDef ->
104 d.d_mem <- d.d_mem || addressible
105 | _ ->
106 sem_error "$ is not a variable" [fId x.x_name]
107 end
108 | Sub (a, i) -> check_var a addressible
109 | Select (r, x) -> check_var r addressible
110 | Deref p -> ()
111 | _ -> sem_error "a variable is needed here" []
112
113 (* |check_expr| -- check and annotate an expression, return its type *)
114 let rec check_expr e env =
115 let t = expr_type e env in
116 e.e_type <- t; t
117
118 (* |expr_type| -- return type of expression *)
119 and expr_type e env =
120 match e.e_guts with
121 Variable x ->
122 let d = lookup_def x env in
123 if not (has_value d) then
124 sem_error "$ is not a variable" [fId x.x_name];
125 if d.d_level < !level then d.d_mem <- true;
126 begin
127 match d.d_kind with
128 ConstDef v ->
129 e.e_value <- Some v
130 | _ -> ()
131 end;
132 d.d_type
133 | Sub (e1, e2) ->
134 let t1 = check_expr e1 env
135 and t2 = check_expr e2 env in
136 if not (same_type t2 integer) then
137 sem_error "subscript is not an integer" [];
138 begin
139 match t1.t_guts with
140 ArrayType (upb, u1) -> u1
141 | _ -> sem_error "subscripting a non-array" []
142 end
143 | Select (e1, x) ->
144 let t1 = check_expr e1 env in
145 err_line := x.x_line;
146 begin
147 match t1.t_guts with
148 RecordType fields ->
149 let d = try find_def x.x_name fields
150 with Not_found ->
151 sem_error "selecting non-existent field" [] in
152 x.x_def <- Some d; d.d_type
153 | _ -> sem_error "selecting from a non-record" []
154 end
155 | Deref e1 ->
156 let t1 = check_expr e1 env in
157 begin
158 match t1.t_guts with
159 PointerType u -> !u
160 | _ -> sem_error "dereferencing a non-pointer" []
161 end
162 | Constant (n, t) -> e.e_value <- Some n; t
163 | String (lab, n) -> row n character
164 | Nil -> e.e_value <- Some 0; addrtype
165 | FuncCall (p, args) ->
166 let v = ref None in
167 let t1 = check_funcall p args env v in
168 if same_type t1 voidtype then
169 sem_error "$ does not return a result" [fId p.x_name];
170 e.e_value <- !v; t1
171 | Monop (w, e1) ->
172 let t = check_monop w (check_expr e1 env) in
173 e.e_value <- try_monop w e1.e_value;
174 t
175 | Binop (w, e1, e2) ->
176 let t = check_binop w (check_expr e1 env) (check_expr e2 env) in
177 e.e_value <- try_binop w e1.e_value e2.e_value;
178 t
179
180 (* |check_funcall| -- check a function or procedure call *)
181 and check_funcall f args env v =
182 let d = lookup_def f env in
183 match d.d_kind with
184 LibDef q ->
185 check_libcall q args env v; d.d_type
186 | ProcDef | PParamDef ->
187 let p = get_proc d.d_type in
188 check_args p.p_fparams args env;
189 p.p_result
190 | _ -> sem_error "$ is not a procedure" [fId f.x_name]
191
192 (* |check_args| -- match formal and actual parameters *)
193 and check_args formals args env =
194 try List.iter2 (fun f a -> check_arg f a env) formals args with
195 Invalid_argument _ ->
196 sem_error "wrong number of arguments" []
197
198 (* |check_arg| -- check one (formal, actual) parameter pair *)
199 and check_arg formal arg env =
200 match formal.d_kind with
201 CParamDef | VParamDef ->
202 let t1 = check_expr arg env in
203 if not (same_type formal.d_type t1) then
204 sem_error "argument has wrong type" [];
205 if formal.d_kind = VParamDef then
206 check_var arg true
207 | PParamDef ->
208 let pf = get_proc formal.d_type in
209 let x = (match arg.e_guts with Variable x -> x
210 | _ -> sem_error "procedure argument must be a proc name" []) in
211 let actual = lookup_def x env in
212 begin
213 match actual.d_kind with
214 ProcDef | PParamDef ->
215 let pa = get_proc actual.d_type in
216 if not (match_args pf.p_fparams pa.p_fparams) then
217 sem_error "argument lists don't match" [];
218 if not (same_type pf.p_result pa.p_result) then
219 sem_error "result types don't match" []
220 | _ ->
221 sem_error "argument $ is not a procedure" [fId x.x_name]
222 end
223 | _ -> failwith "bad formal"
224
225 (* |check_libcall| -- check call to a library procedure *)
226 and check_libcall q args env v =
227 (* |q.q_nargs = -1| if the lib proc has a variable number of arguments;
228 otherwise it is the number of arguments. |q.q_argtypes = []| if the
229 argument types can vary; otherwise it is a list of arg types. *)
230 if q.q_nargs >= 0 && List.length args <> q.q_nargs then
231 sem_error "wrong number of arguments for $" [fLibId q.q_id];
232 if q.q_argtypes <> [] then begin
233 let check t e =
234 if not (same_type t (check_expr e env)) then
235 sem_error "argument of $ has wrong type" [fLibId q.q_id] in
236 List.iter2 check q.q_argtypes args
237 end;
238 match q.q_id with
239 ChrFun ->
240 let e1 = List.hd args in
241 v := e1.e_value
242 | OrdFun ->
243 let e1 = List.hd args in
244 let t1 = check_expr e1 env in
245 if not (discrete t1) then
246 sem_error "ord expects an argument of a discrete type" [];
247 v := e1.e_value
248 | PrintString ->
249 let t1 = check_expr (List.hd args) env in
250 if not (is_string t1) then
251 sem_error "print_string expects a string" []
252 | ReadChar ->
253 check_var (List.hd args) true
254 | NewProc ->
255 let t1 = check_expr (List.hd args) env in
256 if not (is_pointer t1) then
257 sem_error "parameter of new must be a pointer" [];
258 check_var (List.hd args) false
259 | ArgvProc ->
260 let t1 = check_expr (List.nth args 0) env
261 and t2 = check_expr (List.nth args 1) env in
262 if not (same_type t1 integer) || not (is_string t2) then
263 sem_error "type error in parameters of argv" [];
264 check_var (List.nth args 1) true
265 | OpenIn ->
266 let t1 = check_expr (List.nth args 0) env in
267 if not (is_string t1) then
268 sem_error "parameter of open_in is not a string" []
269 | _ -> ()
270
271 (* |check_const| -- check an expression with constant value *)
272 let check_const e env =
273 let t = check_expr e env in
274 match e.e_value with
275 Some v -> (t, v)
276 | None -> sem_error "constant expected" []
277
278
279 (* STATEMENTS *)
280
281 let make_def x k t =
282 { d_tag = x; d_kind = k; d_type = t; d_level = !level;
283 d_mem = false; d_addr = Nowhere }
284
285 (* check_dupcases -- check for duplicate case labels *)
286 let check_dupcases vs =
287 let rec chk =
288 function
289 [] | [_] -> ()
290 | x :: (y :: ys as rest) ->
291 if x = y then sem_error "duplicate case label" [];
292 chk rest in
293 chk (List.sort compare vs)
294
295 (* |check_stmt| -- check and annotate a statement *)
296 let rec check_stmt s env alloc =
297 err_line := s.s_line;
298 match s.s_guts with
299 Skip -> ()
300
301 | Seq ss ->
302 List.iter (fun s1 -> check_stmt s1 env alloc) ss
303
304 | Assign (lhs, rhs) ->
305 let lt = check_expr lhs env
306 and rt = check_expr rhs env in
307 check_var lhs false;
308 if not (same_type lt rt) then
309 sem_error "type mismatch in assignment" []
310
311 | ProcCall (p, args) ->
312 let rt = check_funcall p args env (ref None) in
313 if rt <> voidtype then
314 sem_error "$ returns a result" [fId p.x_name]
315
316 | Return res ->
317 if !level = 0 then
318 sem_error "return statement not allowed in main program" [];
319 begin
320 match res with
321 Some e ->
322 if same_type !return_type voidtype then
323 sem_error "procedure must not return a result" [];
324 let t = check_expr e env in
325 if not (same_type t !return_type) then
326 sem_error "type mismatch in return statement" []
327 | None ->
328 if not (same_type !return_type voidtype) then
329 sem_error "function must return a result" []
330 end
331
332 | IfStmt (cond, thenpt, elsept) ->
333 let ct = check_expr cond env in
334 if not (same_type ct boolean) then
335 sem_error "test in if statement must be a boolean" [];
336 check_stmt thenpt env alloc;
337 check_stmt elsept env alloc
338
339 | WhileStmt (cond, body) ->
340 let ct = check_expr cond env in
341 if not (same_type ct boolean) then
342 sem_error "type mismatch in while statement" [];
343 check_stmt body env alloc
344
345 | RepeatStmt (body, test) ->
346 check_stmt body env alloc;
347 let ct = check_expr test env in
348 if not (same_type ct boolean) then
349 sem_error "type mismatch in repeat statement" []
350
351 | ForStmt (var, lo, hi, body, upb) ->
352 let vt = check_expr var env in
353 let lot = check_expr lo env in
354 let hit = check_expr hi env in
355 if not (same_type vt integer) || not (same_type lot integer)
356 || not (same_type hit integer) then
357 sem_error "type mismatch in for statement" [];
358 check_var var false;
359 check_stmt body env alloc;
360
361 (* Allocate space for hidden variable. In the code, this will
362 be used to save the upper bound. *)
363 let d = make_def (intern "*upb*") VarDef integer in
364 alloc d; upb := Some d
365
366 | CaseStmt (sel, arms, deflt) ->
367 let st = check_expr sel env in
368 if not (scalar st) then
369 sem_error "expression in case statement must be scalar" [];
370
371 let check_arm (lab, body) =
372 let (t1, v) = check_const lab env in
373 if not (same_type t1 st) then
374 sem_error "case label has wrong type" [];
375 check_stmt body env alloc; v in
376
377 let vs = List.map check_arm arms in
378 check_dupcases vs;
379 check_stmt deflt env alloc
380
381
382 (* TYPES AND DECLARATIONS *)
383
384 (* |lookup_typename| -- find a named type in the environment *)
385 let lookup_typename x env =
386 let d = lookup_def x env in
387 match d.d_kind with
388 (TypeDef | HoleDef _) -> d
389 | _ -> sem_error "$ is not a type" [fId x.x_name]
390
391 (* |align| -- increase offset to next multiple of alignment *)
392 let align alignment offset =
393 let margin = !offset mod alignment in
394 if margin <> 0 then offset := !offset - margin + alignment
395
396 (* upward_alloc -- allocate objects upward in memory *)
397 let upward_alloc size d =
398 let r = d.d_type.t_rep in
399 align r.r_align size;
400 let addr = !size in
401 size := !size + r.r_size;
402 d.d_addr <- Local addr
403
404 (* local_alloc -- allocate locals downward in memory *)
405 let local_alloc size nreg d =
406 if !regvars && not d.d_mem && scalar (d.d_type)
407 && !nreg < Mach.nregvars then begin
408 d.d_addr <- Register !nreg; incr nreg
409 end
410 else begin
411 let r = d.d_type.t_rep in
412 align r.r_align size;
413 size := !size + r.r_size;
414 d.d_addr <- Local (local_base - !size)
415 end
416
417 (* param_alloc -- allocate space for formal parameters *)
418 let param_alloc pcount d =
419 let s = param_rep.r_size in
420 match d.d_kind with
421 CParamDef | VParamDef ->
422 d.d_addr <- Local (param_base + s * !pcount);
423 incr pcount
424 | PParamDef ->
425 d.d_addr <- Local (param_base + s * !pcount);
426 pcount := !pcount + 2
427 | _ -> failwith "param_alloc"
428
429 (* |global_alloc| -- allocate label for global variable *)
430 let global_alloc d =
431 d.d_addr <- Global (sprintf "_$" [fId d.d_tag])
432
433 (* |do_alloc| -- call allocation function for definitions that need it *)
434 let do_alloc alloc ds =
435 let h d =
436 match d.d_kind with
437 VarDef | CParamDef | VParamDef | FieldDef | PParamDef ->
438 alloc d
439 | _ -> () in
440 List.iter h ds
441
442 (* |check_typexpr| -- check a type expression, returning the ptype *)
443 let rec check_typexpr te env =
444 match te with
445 TypeName x ->
446 let d = lookup_typename x env in
447 if d.d_kind = TypeDef then d.d_type
448 else sem_error "$ is used before its definition" [fId x.x_name]
449 | Array (upb, value) ->
450 let (t1, v1) = check_const upb env
451 and t2 = check_typexpr value env in
452 if not (same_type t1 integer) then
453 sem_error "upper bound must be an integer" [];
454 row v1 t2
455 | Record fields ->
456 let env' = check_decls fields (new_block env) in
457 let defs = top_block env' in
458 let size = ref 0 in
459 do_alloc (upward_alloc size) defs;
460 align max_align size;
461 let r = { r_size = !size; r_align = max_align } in
462 mk_type (RecordType defs) r
463 | Pointer te ->
464 let t =
465 match te with
466 TypeName x ->
467 let d = lookup_typename x env in
468 begin
469 match d.d_kind with
470 TypeDef -> ref d.d_type
471 | HoleDef h -> h
472 | _ -> failwith "pointer"
473 end
474 | _ -> ref (check_typexpr te env) in
475 mk_type (PointerType t) addr_rep
476
477 (* |check_decl| -- check a declaration and add it to the environment *)
478 and check_decl d env =
479 (* All types of declaration are mixed together in the AST *)
480 match d with
481 ConstDecl (x, e) ->
482 begin
483 match e.e_guts with
484 String (lab, n) ->
485 let t = row n character in
486 let d = make_def x StringDef t in
487 d.d_addr <- Global lab;
488 add_def d env
489 | _ ->
490 let (t, v) = check_const e env in
491 add_def (make_def x (ConstDef v) t) env
492 end
493 | VarDecl (kind, xs, te) ->
494 let t = check_typexpr te env in
495 let def x env =
496 let d = make_def x kind t in
497 add_def d env in
498 Util.accum def xs env
499 | TypeDecl tds ->
500 let tds' =
501 List.map (function (x, te) -> (x, te, ref voidtype)) tds in
502 let add_hole (x, te, h) env1 =
503 add_def (make_def x (HoleDef h) voidtype) env1 in
504 let env' = Util.accum add_hole tds' env in
505 let redefine (x, te, h) env1 =
506 let t = check_typexpr te env1 in
507 h := t; replace (make_def x TypeDef t) env1 in
508 Util.accum redefine tds' env'
509 | ProcDecl (Heading (x, _, _) as heading, body) ->
510 let t = check_heading env heading in
511 let d = make_def x.x_name ProcDef t in
512 d.d_addr <- Global (sprintf "_$" [fId d.d_tag]);
513 x.x_def <- Some d; add_def d env
514 | PParamDecl (Heading (x, _, _) as heading) ->
515 let t = check_heading env heading in
516 let d = make_def x.x_name PParamDef t in
517 add_def d env
518
519 (* |check_heading| -- process a procedure heading into a procedure type *)
520 and check_heading env (Heading (x, fparams, result)) =
521 err_line := x.x_line;
522 incr level;
523 let env' = check_decls fparams (new_block env) in
524 let defs = top_block env' in
525 let pcount = ref 0 in
526 do_alloc (param_alloc pcount) defs;
527 decr level;
528 let rt = (match result with
529 Some te -> check_typexpr te env | None -> voidtype) in
530 if not (same_type rt voidtype) && not (scalar rt) then
531 sem_error "return type must be scalar" [];
532 let p = { p_fparams = defs; p_pcount = !pcount; p_result = rt } in
533 mk_type (ProcType p) proc_rep
534
535 (* |check_decls| -- check a sequence of declarations *)
536 and check_decls ds env =
537 Util.accum check_decl ds env
538
539 (* Storage is allocated for local variables in a separate phase from
540 processing the declarations. That makes it possible to gather
541 additional innformation about the usage of variables (i.e., whether
542 they must be addressible) before deciding which can live in
543 registers. *)
544
545 (* |check_block| -- check a local block *)
546 let rec check_block level rt env (Block (ds, ss, fsize, nregv)) =
547 let env' = check_decls ds (new_block env) in
548 let defs = ref (top_block env') in
549 let pre_alloc d = defs := !defs @ [d] in
550 check_bodies env' ds;
551 return_type := rt;
552 check_stmt ss env' pre_alloc;
553 do_alloc (local_alloc fsize nregv) !defs;
554 align max_align fsize
555
556 (* |check_bodies| -- check bodies of procedure declarations *)
557 and check_bodies env ds =
558 let check =
559 function
560 ProcDecl (Heading(x, _, _), body) ->
561 let d = get_def x in
562 let p = get_proc d.d_type in
563 let env' = add_block p.p_fparams env in
564 incr level;
565 check_block d.d_level p.p_result env' body;
566 decr level
567 | _ -> () in
568 List.iter check ds
569
570
571 (* INITIAL ENVIRONMENT *)
572
573 let defn (x, k, t) env =
574 let d = { d_tag = intern x; d_kind = k; d_type = t;
575 d_level = 0; d_mem = false; d_addr = Nowhere } in
576 define d env
577
578 let libproc i n ts =
579 LibDef { q_id = i; q_nargs = n; q_argtypes = ts }
580
581 let operator op ts =
582 libproc (Operator op) (List.length ts) ts
583
584 (* |init_env| -- environment for whole program *)
585 let init_env =
586 Util.accum defn
587 [ ("integer", TypeDef, integer);
588 ("char", TypeDef, character);
589 ("boolean", TypeDef, boolean);
590 ("true", ConstDef 1, boolean);
591 ("false", ConstDef 0, boolean);
592 ("chr", libproc ChrFun 1 [integer], character);
593 ("ord", libproc OrdFun 1 [], integer);
594 ("print_num", libproc PrintNum 1 [integer], voidtype);
595 ("print_char", libproc PrintChar 1 [character], voidtype);
596 ("print_string", libproc PrintString 1 [], voidtype);
597 ("open_in", libproc OpenIn 1 [], boolean);
598 ("close_in", libproc CloseIn 0 [], voidtype);
599 ("newline", libproc NewLine 0 [], voidtype);
600 ("read_char", libproc ReadChar 1 [character], voidtype);
601 ("exit", libproc ExitProc 1 [integer], voidtype);
602 ("new", libproc NewProc 1 [], voidtype);
603 ("argc", libproc ArgcFun 0 [], integer);
604 ("argv", libproc ArgvProc 2 [], voidtype);
605 ("lsl", operator Lsl [integer; integer], integer);
606 ("lsr", operator Lsr [integer; integer], integer);
607 ("asr", operator Asr [integer; integer], integer);
608 ("bitand", operator BitAnd [integer; integer], integer);
609 ("bitor", operator BitOr [integer; integer], integer);
610 ("bitnot", operator BitNot [integer], integer)] empty
611
612 (* |annotate| -- annotate the whole program *)
613 let annotate (Prog (Block (globals, ss, fsize, nregv), glodefs)) =
614 level := 0;
615 let env = check_decls globals (new_block init_env) in
616 do_alloc global_alloc (top_block env);
617 check_bodies env globals;
618 return_type := voidtype;
619 level := 1;
620 let alloc = local_alloc fsize nregv in
621 check_stmt ss env alloc;
622 align max_align fsize;
623 glodefs := top_block env