annotate ppc/check.ml @ 1:b5139af1a420 tip basis

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