Add option iter
[tiger.ml.git] / compiler / src / lib / tiger / tiger_semant.ml
1 module List = ListLabels
2
3 module A = Tiger_absyn
4 module Dag = Tiger_dag
5 module Env = Tiger_env
6 module E = Tiger_error
7 module Pos = Tiger_position
8 module Sym = Tiger_symbol
9 module Translate = Tiger_translate
10 module Type = Tiger_env_type
11 module Value = Tiger_env_value
12
13 (* The only reason for having this seemingly-superfluous inner module is to
14 * have this nice signature as a summary of what each function does. *)
15 module Semant : sig
16 type expty =
17 { exp : Translate.exp
18 ; ty : Type.t
19 }
20
21 (* Violating normal naming convention just to make it easier to follow
22 * Appel's
23 *)
24 val transExp : env:Env.t -> A.exp -> expty
25
26 (* transVar does not seem to be needed, as trvar handles all our cases.
27 * Am I wrong?
28 *
29 * val transVar : env:Env.t -> A.var -> expty
30 *
31 *)
32 end = struct
33 type expty =
34 { exp : Translate.exp
35 ; ty : Type.t
36 }
37
38 let rec actual_ty ty ~pos =
39 match ty with
40 | Type.Name (name, ty_opt_ref) ->
41 (match !ty_opt_ref with
42 | None ->
43 E.raise (E.Unknown_type {ty_id=name; pos})
44 | Some ty ->
45 actual_ty ty ~pos
46 )
47 | Type.Unit
48 | Type.Nil
49 | Type.Int
50 | Type.String
51 | Type.Record _
52 | Type.Array _ ->
53 ty
54
55 let return ty = {exp = (); ty}
56 let return_unit = return Type.Unit
57 let return_nil = return Type.Nil
58 let return_int = return Type.Int
59 let return_string = return Type.String
60
61 let env_get_typ ~sym ~env ~pos : Type.t =
62 match Env.get_typ env sym with
63 | Some ty -> ty
64 | None -> E.raise (E.Unknown_type {ty_id=sym; pos})
65
66 let env_get_typ_actual ~sym ~env ~pos : Type.t =
67 actual_ty (env_get_typ ~sym ~env ~pos) ~pos
68
69 let env_get_val ~sym ~env ~pos : Value.t =
70 match Env.get_val env sym with
71 | Some ty -> ty
72 | None -> E.raise (E.Unknown_id {id=sym; pos})
73
74 let check_same {exp=_; ty=ty_left} {exp=_; ty=ty_right} ~pos : unit =
75 if Type.is_equal ty_left ty_right then
76 ()
77 else
78 E.raise (E.Wrong_type {expected=ty_left; given=ty_right; pos})
79
80 let check_int expty ~pos : unit =
81 check_same return_int expty ~pos
82
83 let paths_of_typedecs typedecs : (Sym.t * Sym.t * Pos.t) list list =
84 let (path, paths) =
85 List.fold_left typedecs ~init:([], []) ~f:(
86 fun (path, paths) (A.TypeDec {name=child; ty; pos}) ->
87 match ty with
88 | A.NameTy {symbol=parent; _} ->
89 (((parent, child, pos) :: path), paths)
90 | A.RecordTy _
91 | A.ArrayTy _ ->
92 ([], path :: paths)
93 )
94 in
95 List.map (path :: paths) ~f:List.rev
96
97 let check_cycles (typedecs : A.typedec list) : unit =
98 let non_empty_paths =
99 List.filter
100 (paths_of_typedecs typedecs)
101 ~f:(function [] -> false | _ -> true)
102 in
103 List.iter non_empty_paths ~f:(
104 fun path ->
105 match Dag.of_list (List.map path ~f:(fun (p, c, _) -> (p, c))) with
106 | Ok _ ->
107 ()
108 | Error `Cycle ->
109 let (_, from_id, from_pos) = List.hd path in
110 let (_, to_id, to_pos) = List.hd (List.rev path) in
111 E.raise (E.Cycle_in_type_decs {from_id; from_pos; to_id; to_pos})
112 )
113
114 let rec transExp ~env exp =
115 let rec trexp exp =
116 (match exp with
117 | A.NilExp ->
118 return_nil
119 | A.IntExp _ ->
120 return_int
121 | A.StringExp {string=_; _} ->
122 return_string
123 | A.CallExp {func; args; pos} ->
124 (match env_get_val ~sym:func ~env ~pos with
125 | Value.Fun {formals; result} ->
126 let expected = List.length formals in
127 let given = List.length args in
128 if given = expected then
129 begin
130 List.iter2 formals args ~f:(fun ty_expected exp_given ->
131 check_same
132 (return (actual_ty ~pos ty_expected))
133 (trexp exp_given)
134 ~pos;
135 );
136 return (actual_ty ~pos result)
137 end
138 else
139 E.raise (E.Wrong_number_of_args {func; expected; given; pos})
140 | Value.Var _ ->
141 E.raise (E.Id_not_a_function {id=func; pos})
142 )
143 | A.OpExp {oper; left; right; pos} ->
144 trop oper ~left ~right ~pos
145 | A.RecordExp {fields=field_exps; typ; pos} ->
146 let ty = env_get_typ_actual ~sym:typ ~env ~pos in
147 Type.if_record
148 ty
149 ~f:(fun field_tys ->
150 List.iter field_exps ~f:(fun (field, exp, pos) ->
151 (match List.assoc_opt field field_tys with
152 | Some field_ty ->
153 check_same (return (actual_ty ~pos field_ty)) (trexp exp) ~pos
154 | None ->
155 E.raise
156 (E.No_such_field_in_record {field; record=ty; pos})
157 )
158 )
159 )
160 ~otherwise:(fun () ->
161 E.raise (E.Wrong_type_used_as_record {ty_id=typ; ty; pos})
162 );
163 return (actual_ty ~pos ty)
164 | A.SeqExp [] ->
165 return_unit
166 | A.SeqExp exps ->
167 let last xs =
168 xs
169 |> List.rev (* Yes, redundant, but clean-looking ;-P *)
170 |> List.hd (* Empty is matched in above SeqExp match case *)
171 in
172 exps
173 |> List.map ~f:(fun (exp, _) -> trexp exp)
174 |> last
175 | A.AssignExp {var; exp; pos} ->
176 check_same (trvar var) (trexp exp) ~pos;
177 (* TODO: Add var->exp to val env? *)
178 return_unit
179 | A.IfExp {test; then'; else'; pos} ->
180 (* test : must be int, because we have no bool *)
181 (* then : must equal else *)
182 (* else : must equal then or be None *)
183 check_int (trexp test) ~pos;
184 (match (trexp then', else') with
185 | expty_then, None ->
186 expty_then
187 | expty_then, Some else' ->
188 let expty_else = trexp else' in
189 check_same expty_then expty_else ~pos;
190 expty_then
191 )
192 | A.WhileExp {test; body; pos} ->
193 (* test : must be int, because we have no bool *)
194 check_int (trexp test) ~pos;
195 let (loop, env) = Env.loop_begin env in
196 (* Only care if an error is raised *)
197 ignore (transExp ~env body);
198 ignore (Env.loop_end env loop);
199 return_unit
200 | A.ForExp {var; lo; hi; body; pos; escape=_} ->
201 check_int (trexp lo) ~pos;
202 check_int (trexp hi) ~pos;
203 let (loop, env) = Env.loop_begin env in
204 let env = Env.set_val env var (Value.Var {ty = Type.Int}) in
205 (* Only care if an error is raised *)
206 ignore (transExp ~env body);
207 ignore (Env.loop_end env loop);
208 return_unit
209 | A.BreakExp pos ->
210 (match Env.loop_current env with
211 | Some _ -> ()
212 | None -> E.raise (E.Break_outside_loop pos)
213 );
214 return_unit
215 | A.LetExp {decs; body; pos=_} ->
216 (* (1) decs augment env *)
217 (* (2) body checked against the new env *)
218 let env =
219 List.fold_left decs ~init:env ~f:(fun env dec -> transDec dec ~env)
220 in
221 transExp body ~env
222 | A.ArrayExp {typ; size; init; pos} ->
223 check_int (trexp size) ~pos;
224 let ty = env_get_typ_actual ~sym:typ ~env ~pos in
225 Type.if_array
226 ty
227 ~f:(fun ty_elements ->
228 check_same (return (actual_ty ~pos ty_elements)) (trexp init) ~pos
229 )
230 ~otherwise:(fun () ->
231 E.raise (E.Wrong_type_used_as_array {ty_id=typ; ty; pos})
232 );
233 return (actual_ty ~pos ty)
234 | A.VarExp var ->
235 trvar var
236 )
237 and trvar =
238 (function
239 | A.SimpleVar {symbol=sym; pos} ->
240 (match env_get_val ~sym ~env ~pos with
241 | Value.Fun _ -> E.raise (E.Id_is_a_function {id=sym; pos})
242 | Value.Var {ty} -> return (actual_ty ~pos ty)
243 )
244 | A.FieldVar {var; symbol; pos} ->
245 let {exp=_; ty} = trvar var in
246 Type.if_record
247 ty
248 ~f:(fun fields ->
249 (match List.assoc_opt symbol fields with
250 | None ->
251 E.raise
252 (E.No_such_field_in_record {field=symbol; record=ty; pos})
253 | Some ty ->
254 return (actual_ty ~pos ty)
255 )
256 )
257 ~otherwise:(fun () -> E.raise (E.Exp_not_a_record {ty; pos}))
258 | A.SubscriptVar {var; exp; pos} ->
259 let {exp=_; ty} = trvar var in
260 check_int (trexp exp) ~pos;
261 Type.if_array
262 ty
263 ~f:(fun ty_elements -> return (actual_ty ~pos ty_elements))
264 ~otherwise:(fun () -> E.raise (E.Exp_not_an_array {ty; pos}))
265 )
266 and trop oper ~left ~right ~pos =
267 (* TODO: Refactor trop - all opers return bool/int *)
268 let expty_left = trexp left in
269 let expty_right = trexp right in
270 check_same expty_left expty_right ~pos;
271 let {exp=_; ty} = expty_left in
272 let module T = Type in
273 (match oper with
274 (* Arithmetic: int *)
275 | A.PlusOp
276 | A.MinusOp
277 | A.TimesOp
278 | A.DivideOp ->
279 check_int expty_left ~pos;
280 return_int
281 (* Equality: int, string, array, record *)
282 | A.EqOp
283 | A.NeqOp ->
284 if (T.is_int ty)
285 || (T.is_string ty)
286 || (T.is_array ty)
287 || (T.is_record ty)
288 then
289 return_int (* Because we have no bool type *)
290 else
291 E.raise (E.Invalid_operand_type
292 { oper
293 ; valid = ["int"; "string"; "array"; "record"]
294 ; given = ty
295 ; pos
296 })
297 (* Order: int, string *)
298 | A.LtOp
299 | A.LeOp
300 | A.GtOp
301 | A.GeOp ->
302 if (T.is_int ty)
303 || (T.is_string ty)
304 then
305 return_int (* Because we have no bool type *)
306 else
307 E.raise (E.Invalid_operand_type
308 { oper
309 ; valid = ["int"; "string"]
310 ; given = ty
311 ; pos
312 })
313 )
314 in
315 trexp exp
316 and transDec ~(env : Env.t) (dec : A.dec) : Env.t =
317 (match dec with
318 | A.VarDec {name; typ=typ_opt; init; pos=pos_outter; escape=_} ->
319 let ty =
320 (match (typ_opt, transExp ~env init) with
321 | None, {ty; exp=()} ->
322 ty
323 | Some (sym, pos_inner), expty_init ->
324 let ty = env_get_typ_actual ~sym ~env ~pos:pos_inner in
325 check_same (return ty) expty_init ~pos:pos_outter;
326 ty
327 )
328 in
329 Env.set_val env name (Value.Var {ty})
330 | A.TypeDecs typedecs ->
331 check_cycles typedecs;
332 let env =
333 List.fold_left typedecs ~init:env ~f:(
334 fun env (A.TypeDec {name; ty=_; pos=_}) ->
335 Env.set_typ env name (Type.Name (name, ref None))
336 )
337 in
338 List.iter typedecs ~f:(fun (A.TypeDec {name=ty_name; ty=ty_exp; pos}) ->
339 let ty = transTy ~env ~ty_name ~ty_exp in
340 (match env_get_typ ~sym:ty_name ~env ~pos with
341 | Type.Name (_, ty_opt_ref) ->
342 ty_opt_ref := Some ty
343 | Type.Unit
344 | Type.Nil
345 | Type.Int
346 | Type.String
347 | Type.Record _
348 | Type.Array _ ->
349 ()
350 )
351 );
352 env
353 | A.FunDecs fundecs ->
354 let env_with_fun_heads_only =
355 List.fold_left fundecs ~init:env ~f:(
356 fun env (A.FunDec {name; params; result; body=_; pos=_}) ->
357 let formals =
358 List.map params ~f:(
359 fun (A.Field {name=_; typ; pos; escape=_}) ->
360 env_get_typ_actual ~env ~sym:typ ~pos
361 )
362 in
363 let result =
364 match result with
365 | Some (s, p) -> env_get_typ_actual ~sym:s ~env ~pos:p
366 | None -> Type.Unit
367 in
368 Env.set_val env name (Value.Fun {formals; result})
369 )
370 in
371 List.iter fundecs ~f:(
372 fun (A.FunDec {name=_; params; result=_; body; pos=_}) ->
373 let env_with_fun_heads_and_local_vars =
374 List.fold_left params ~init:env_with_fun_heads_only ~f:(
375 fun env (A.Field {name=var_name; escape=_; typ; pos}) ->
376 let var_ty = env_get_typ_actual ~env ~sym:typ ~pos in
377 Env.set_val env var_name (Value.Var {ty = var_ty})
378 )
379 in
380 (* we only care if an exception is raised *)
381 ignore (transExp ~env:env_with_fun_heads_and_local_vars body);
382 );
383 env_with_fun_heads_only
384 )
385 and transTy ~(env : Env.t) ~ty_name ~(ty_exp : A.ty) : Type.t =
386 (match ty_exp with
387 | A.NameTy {symbol=sym; pos} ->
388 env_get_typ ~sym ~env ~pos
389 | A.RecordTy fields ->
390 let fields =
391 List.map fields ~f:(fun (A.Field {name; escape=_; typ; pos}) ->
392 let ty = env_get_typ ~sym:typ ~env ~pos in
393 (name, ty)
394 )
395 in
396 Type.new_record ~name:ty_name ~fields
397 | A.ArrayTy {symbol=sym; pos} ->
398 let element_ty = env_get_typ ~sym ~env ~pos in
399 Type.new_array ~name:ty_name ~ty:element_ty
400 )
401 end
402
403 open Semant
404
405 let transProg absyn =
406 let {exp = _; ty = _} = transExp absyn ~env:Env.base in
407 ()
This page took 0.134408 seconds and 4 git commands to generate.