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