1 module List = ListLabels
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
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. *)
21 (* Violating normal naming convention just to make it easier to follow
24 val transExp : env:Env.t -> A.exp -> expty
26 (* transVar does not seem to be needed, as trvar handles all our cases.
29 * val transVar : env:Env.t -> A.var -> expty
38 let rec actual_ty ty ~pos =
40 | Type.Name (name, ty_opt_ref) ->
41 (match !ty_opt_ref with
43 E.raise (E.Unknown_type {ty_id=name; pos})
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
61 let env_get_typ ~sym ~env ~pos : Type.t =
62 match Env.get_typ env sym with
64 | None -> E.raise (E.Unknown_type {ty_id=sym; pos})
66 let env_get_typ_actual ~sym ~env ~pos : Type.t =
67 actual_ty (env_get_typ ~sym ~env ~pos) ~pos
69 let env_get_val ~sym ~env ~pos : Value.t =
70 match Env.get_val env sym with
72 | None -> E.raise (E.Unknown_id {id=sym; pos})
74 let check_same {exp=_; ty=ty_left} {exp=_; ty=ty_right} ~pos : unit =
75 if Type.is_equal ty_left ty_right then
78 E.raise (E.Wrong_type {expected=ty_left; given=ty_right; pos})
80 let check_int expty ~pos : unit =
81 check_same return_int expty ~pos
83 let paths_of_typedecs typedecs : (Sym.t * Sym.t * Pos.t) list list =
85 List.fold_left typedecs ~init:([], []) ~f:(
86 fun (path, paths) (A.TypeDec {name=child; ty; pos}) ->
88 | A.NameTy {symbol=parent; _} ->
89 (((parent, child, pos) :: path), paths)
95 List.map (path :: paths) ~f:List.rev
97 let check_cycles (typedecs : A.typedec list) : unit =
100 (paths_of_typedecs typedecs)
101 ~f:(function [] -> false | _ -> true)
103 List.iter non_empty_paths ~f:(
105 match Dag.of_list (List.map path ~f:(fun (p, c, _) -> (p, c))) with
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})
114 let rec transExp ~env exp =
121 | A.StringExp {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
130 List.iter2 formals args ~f:(fun ty_expected exp_given ->
132 (return (actual_ty ~pos ty_expected))
136 return (actual_ty ~pos result)
139 E.raise (E.Wrong_number_of_args {func; expected; given; pos})
141 E.raise (E.Id_not_a_function {id=func; pos})
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
150 List.iter field_exps ~f:(fun (field, exp, pos) ->
151 (match List.assoc_opt field field_tys with
153 check_same (return (actual_ty ~pos field_ty)) (trexp exp) ~pos
156 (E.No_such_field_in_record {field; record=ty; pos})
160 ~otherwise:(fun () ->
161 E.raise (E.Wrong_type_used_as_record {ty_id=typ; ty; pos})
163 return (actual_ty ~pos ty)
169 |> List.rev (* Yes, redundant, but clean-looking ;-P *)
170 |> List.hd (* Empty is matched in above SeqExp match case *)
173 |> List.map ~f:(fun (exp, _) -> trexp exp)
175 | A.AssignExp {var; exp; pos} ->
176 check_same (trvar var) (trexp exp) ~pos;
177 (* TODO: Add var->exp to val env? *)
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 ->
187 | expty_then, Some else' ->
188 let expty_else = trexp else' in
189 check_same expty_then expty_else ~pos;
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);
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);
210 (match Env.loop_current env with
212 | None -> E.raise (E.Break_outside_loop pos)
215 | A.LetExp {decs; body; pos=_} ->
216 (* (1) decs augment env *)
217 (* (2) body checked against the new env *)
219 List.fold_left decs ~init:env ~f:(fun env dec -> transDec dec ~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
227 ~f:(fun ty_elements ->
228 check_same (return (actual_ty ~pos ty_elements)) (trexp init) ~pos
230 ~otherwise:(fun () ->
231 E.raise (E.Wrong_type_used_as_array {ty_id=typ; ty; pos})
233 return (actual_ty ~pos ty)
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)
244 | A.FieldVar {var; symbol; pos} ->
245 let {exp=_; ty} = trvar var in
249 (match List.assoc_opt symbol fields with
252 (E.No_such_field_in_record {field=symbol; record=ty; pos})
254 return (actual_ty ~pos ty)
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;
263 ~f:(fun ty_elements -> return (actual_ty ~pos ty_elements))
264 ~otherwise:(fun () -> E.raise (E.Exp_not_an_array {ty; pos}))
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
274 (* Arithmetic: int *)
279 check_int expty_left ~pos;
281 (* Equality: int, string, array, record *)
289 return_int (* Because we have no bool type *)
291 E.raise (E.Invalid_operand_type
293 ; valid = ["int"; "string"; "array"; "record"]
297 (* Order: int, string *)
305 return_int (* Because we have no bool type *)
307 E.raise (E.Invalid_operand_type
309 ; valid = ["int"; "string"]
316 and transDec ~(env : Env.t) (dec : A.dec) : Env.t =
318 | A.VarDec {name; typ=typ_opt; init; pos=pos_outter; escape=_} ->
320 (match (typ_opt, transExp ~env init) with
321 | None, {ty; exp=()} ->
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;
329 Env.set_val env name (Value.Var {ty})
330 | A.TypeDecs typedecs ->
331 check_cycles typedecs;
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))
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
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=_}) ->
359 fun (A.Field {name=_; typ; pos; escape=_}) ->
360 env_get_typ_actual ~env ~sym:typ ~pos
365 | Some (s, p) -> env_get_typ_actual ~sym:s ~env ~pos:p
368 Env.set_val env name (Value.Fun {formals; result})
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})
380 (* we only care if an exception is raised *)
381 ignore (transExp ~env:env_with_fun_heads_and_local_vars body);
383 env_with_fun_heads_only
385 and transTy ~(env : Env.t) ~ty_name ~(ty_exp : A.ty) : Type.t =
387 | A.NameTy {symbol=sym; pos} ->
388 env_get_typ ~sym ~env ~pos
389 | A.RecordTy fields ->
391 List.map fields ~f:(fun (A.Field {name; escape=_; typ; pos}) ->
392 let ty = env_get_typ ~sym:typ ~env ~pos 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
405 let transProg absyn =
406 let {exp = _; ty = _} = transExp absyn ~env:Env.base in