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