annotate lab3/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 (* lab3/check.ml *)
mike@0 2 (* Copyright (c) 2017 J. M. Spivey *)
mike@0 3
mike@0 4 open Tree
mike@0 5 open Dict
mike@0 6 open Print
mike@0 7
mike@0 8 (* |err_line| -- line number for error messages *)
mike@0 9 let err_line = ref 1
mike@0 10
mike@0 11 (* |Semantic_error| -- exception raised if error detected *)
mike@0 12 exception Semantic_error of string * Print.arg list * int
mike@0 13
mike@0 14 (* |sem_error| -- issue error message by raising exception *)
mike@0 15 let sem_error fmt args =
mike@0 16 raise (Semantic_error (fmt, args, !err_line))
mike@0 17
mike@0 18 (* |accum| -- fold_left with arguments swapped *)
mike@0 19 let rec accum f xs a =
mike@0 20 match xs with
mike@0 21 [] -> a
mike@0 22 | y::ys -> accum f ys (f y a)
mike@0 23
mike@0 24 (* |lookup_def| -- find definition of a name, give error is none *)
mike@0 25 let lookup_def x env =
mike@0 26 err_line := x.x_line;
mike@0 27 try let d = lookup x.x_name env in x.x_def <- Some d; d with
mike@0 28 Not_found -> sem_error "$ is not declared" [fStr x.x_name]
mike@0 29
mike@0 30 (* |add_def| -- add definition to env, give error if already declared *)
mike@0 31 let add_def d env =
mike@0 32 try define d env with
mike@0 33 Exit -> sem_error "$ is already declared" [fStr d.d_tag]
mike@0 34
mike@0 35 (* |check_expr| -- check and annotate an expression *)
mike@0 36 let rec check_expr e env =
mike@0 37 match e with
mike@0 38 Constant n -> ()
mike@0 39 | Variable x ->
mike@0 40 let d = lookup_def x env in
mike@0 41 begin
mike@0 42 match d.d_kind with
mike@0 43 VarDef -> ()
mike@0 44 | ProcDef _ ->
mike@0 45 sem_error "$ is not a variable" [fStr x.x_name]
mike@0 46 end
mike@0 47 | Monop (w, e1) ->
mike@0 48 check_expr e1 env
mike@0 49 | Binop (w, e1, e2) ->
mike@0 50 check_expr e1 env;
mike@0 51 check_expr e2 env
mike@0 52 | Call (p, args) ->
mike@0 53 let d = lookup_def p env in
mike@0 54 begin
mike@0 55 match d.d_kind with
mike@0 56 VarDef ->
mike@0 57 sem_error "$ is not a procedure" [fStr p.x_name]
mike@0 58 | ProcDef nargs ->
mike@0 59 if List.length args <> nargs then
mike@0 60 sem_error "procedure $ needs $ arguments"
mike@0 61 [fStr p.x_name; fNum nargs];
mike@0 62 end;
mike@0 63 List.iter (fun e1 -> check_expr e1 env) args
mike@0 64
mike@0 65 (* |check_stmt| -- check and annotate a statement *)
mike@0 66 let rec check_stmt s inproc env =
mike@0 67 match s with
mike@0 68 Skip -> ()
mike@0 69 | Seq ss ->
mike@0 70 List.iter (fun s1 -> check_stmt s1 inproc env) ss
mike@0 71 | Assign (x, e) ->
mike@0 72 let d = lookup_def x env in
mike@0 73 begin
mike@0 74 match d.d_kind with
mike@0 75 VarDef -> check_expr e env
mike@0 76 | ProcDef _ ->
mike@0 77 sem_error "$ is not a variable" [fStr x.x_name]
mike@0 78 end
mike@0 79 | Return e ->
mike@0 80 if not inproc then
mike@0 81 sem_error "return statement only allowed in procedure" [];
mike@0 82 check_expr e env
mike@0 83 | IfStmt (test, thenpt, elsept) ->
mike@0 84 check_expr test env;
mike@0 85 check_stmt thenpt inproc env;
mike@0 86 check_stmt elsept inproc env
mike@0 87 | WhileStmt (test, body) ->
mike@0 88 check_expr test env;
mike@0 89 check_stmt body inproc env
mike@0 90 | Print e ->
mike@0 91 check_expr e env
mike@0 92 | Newline ->
mike@0 93 ()
mike@0 94
mike@0 95 (* |serialize| -- number a list, starting from 0 *)
mike@0 96 let serialize xs =
mike@0 97 let rec count i =
mike@0 98 function
mike@0 99 [] -> []
mike@0 100 | x :: xs -> (i, x) :: count (i+1) xs in
mike@0 101 count 0 xs
mike@0 102
mike@0 103 (*
mike@0 104 Frame layout
mike@0 105
mike@0 106 arg n
mike@0 107 ...
mike@0 108 fp+16: arg 1
mike@0 109 fp+12: static link
mike@0 110 fp+8: current cp
mike@0 111 fp+4: return addr
mike@0 112 fp: dynamic link
mike@0 113 fp-4: local 1
mike@0 114 ...
mike@0 115 local m
mike@0 116 *)
mike@0 117
mike@0 118 let arg_base = 16
mike@0 119 let loc_base = 0
mike@0 120
mike@0 121 (* |declare_local| -- declare a formal parameter or local *)
mike@0 122 let declare_local x lev off env =
mike@0 123 let d = { d_tag = x; d_kind = VarDef; d_level = lev;
mike@0 124 d_lab = ""; d_off = off } in
mike@0 125 add_def d env
mike@0 126
mike@0 127 (* |declare_global| -- declare a global variable *)
mike@0 128 let declare_global x env =
mike@0 129 let d = { d_tag = x; d_kind = VarDef; d_level = 0;
mike@0 130 d_lab = sprintf "_$" [fStr x]; d_off = 0 } in
mike@0 131 add_def d env
mike@0 132
mike@0 133 (* |declare_proc| -- declare a procedure *)
mike@0 134 let declare_proc (Proc (p, formals, body)) lev env =
mike@0 135 let lab = sprintf "$_$" [fStr p.x_name; fNum (label ())] in
mike@0 136 let d = { d_tag = p.x_name;
mike@0 137 d_kind = ProcDef (List.length formals); d_level = lev;
mike@0 138 d_lab = lab; d_off = 0 } in
mike@0 139 p.x_def <- Some d; add_def d env
mike@0 140
mike@0 141 (* |check_proc| -- check a procedure body *)
mike@0 142 let rec check_proc (Proc (p, formals, Block (vars, procs, body))) lev env =
mike@0 143 err_line := p.x_line;
mike@0 144 let env' =
mike@0 145 accum (fun (i, x) -> declare_local x lev (arg_base + 4*i))
mike@0 146 (serialize formals) (new_block env) in
mike@0 147 let env'' =
mike@0 148 accum (fun (i, x) -> declare_local x lev (loc_base - 4*(i+1)))
mike@0 149 (serialize vars) env' in
mike@0 150 let env''' =
mike@0 151 accum (fun d -> declare_proc d (lev+1)) procs env'' in
mike@0 152 List.iter (fun d -> check_proc d (lev+1) env''') procs;
mike@0 153 check_stmt body true env'''
mike@0 154
mike@0 155 (* |annotate| -- check and annotate a program *)
mike@0 156 let annotate (Program (Block (vars, procs, body))) =
mike@0 157 let env = accum declare_global vars empty in
mike@0 158 let env' = accum (fun d -> declare_proc d 1) procs env in
mike@0 159 List.iter (fun d -> check_proc d 1 env') procs;
mike@0 160 check_stmt body false env'