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 ignore (trexp body); (* Only care if a type-error is raised *)
197 | A.ForExp {var; lo; hi; body; pos; escape=_} ->
198 check_int (trexp lo) ~pos;
199 check_int (trexp hi) ~pos;
200 (* Only care if a type-error is raised *)
201 let env = Env.set_val env var (Value.Var {ty = Type.Int}) in
202 ignore (transExp ~env body);
206 | A.LetExp {decs; body; pos=_} ->
207 (* (1) decs augment env *)
208 (* (2) body checked against the new env *)
210 List.fold_left decs ~init:env ~f:(fun env dec -> transDec dec ~env)
213 | A.ArrayExp {typ; size; init; pos} ->
214 check_int (trexp size) ~pos;
215 let ty = env_get_typ_actual ~sym:typ ~env ~pos in
218 ~f:(fun ty_elements ->
219 check_same (return (actual_ty ~pos ty_elements)) (trexp init) ~pos
221 ~otherwise:(fun () ->
222 E.raise (E.Wrong_type_used_as_array {ty_id=typ; ty; pos})
224 return (actual_ty ~pos ty)
230 | A.SimpleVar {symbol=sym; pos} ->
231 (match env_get_val ~sym ~env ~pos with
232 | Value.Fun _ -> E.raise (E.Id_is_a_function {id=sym; pos})
233 | Value.Var {ty} -> return (actual_ty ~pos ty)
235 | A.FieldVar {var; symbol; pos} ->
236 let {exp=_; ty} = trvar var in
240 (match List.assoc_opt symbol fields with
243 (E.No_such_field_in_record {field=symbol; record=ty; pos})
245 return (actual_ty ~pos ty)
248 ~otherwise:(fun () -> E.raise (E.Exp_not_a_record {ty; pos}))
249 | A.SubscriptVar {var; exp; pos} ->
250 let {exp=_; ty} = trvar var in
251 check_int (trexp exp) ~pos;
254 ~f:(fun ty_elements -> return (actual_ty ~pos ty_elements))
255 ~otherwise:(fun () -> E.raise (E.Exp_not_an_array {ty; pos}))
257 and trop oper ~left ~right ~pos =
258 (* TODO: Refactor trop - all opers return bool/int *)
259 let expty_left = trexp left in
260 let expty_right = trexp right in
261 check_same expty_left expty_right ~pos;
262 let {exp=_; ty} = expty_left in
263 let module T = Type in
265 (* Arithmetic: int *)
270 check_int expty_left ~pos;
272 (* Equality: int, string, array, record *)
280 return_int (* Because we have no bool type *)
282 E.raise (E.Invalid_operand_type
284 ; valid = ["int"; "string"; "array"; "record"]
288 (* Order: int, string *)
296 return_int (* Because we have no bool type *)
298 E.raise (E.Invalid_operand_type
300 ; valid = ["int"; "string"]
307 and transDec ~(env : Env.t) (dec : A.dec) : Env.t =
309 | A.VarDec {name; typ=typ_opt; init; pos=pos_outter; escape=_} ->
311 (match (typ_opt, transExp ~env init) with
312 | None, {ty; exp=()} ->
314 | Some (sym, pos_inner), expty_init ->
315 let ty = env_get_typ_actual ~sym ~env ~pos:pos_inner in
316 check_same (return ty) expty_init ~pos:pos_outter;
320 Env.set_val env name (Value.Var {ty})
321 | A.TypeDecs typedecs ->
322 check_cycles typedecs;
324 List.fold_left typedecs ~init:env ~f:(
325 fun env (A.TypeDec {name; ty=_; pos=_}) ->
326 Env.set_typ env name (Type.Name (name, ref None))
329 List.iter typedecs ~f:(fun (A.TypeDec {name; ty=ty_exp; pos}) ->
330 let ty = transTy ~env ty_exp in
331 (match env_get_typ ~sym:name ~env ~pos with
332 | Type.Name (_, ty_opt_ref) ->
333 ty_opt_ref := Some ty
344 | A.FunDecs fundecs ->
345 let env_with_fun_heads_only =
346 List.fold_left fundecs ~init:env ~f:(
347 fun env (A.FunDec {name; params; result; body=_; pos=_}) ->
350 fun (A.Field {name=_; typ; pos; escape=_}) ->
351 env_get_typ_actual ~env ~sym:typ ~pos
356 | Some (s, p) -> env_get_typ_actual ~sym:s ~env ~pos:p
359 Env.set_val env name (Value.Fun {formals; result})
362 List.iter fundecs ~f:(
363 fun (A.FunDec {name=_; params; result=_; body; pos=_}) ->
364 let env_with_fun_heads_and_local_vars =
365 List.fold_left params ~init:env_with_fun_heads_only ~f:(
366 fun env (A.Field {name=var_name; escape=_; typ; pos}) ->
367 let var_ty = env_get_typ_actual ~env ~sym:typ ~pos in
368 Env.set_val env var_name (Value.Var {ty = var_ty})
371 (* we only care if an exception is raised *)
372 ignore (transExp ~env:env_with_fun_heads_and_local_vars body);
374 env_with_fun_heads_only
376 and transTy ~(env : Env.t) (ty_exp : A.ty) : Type.t =
378 | A.NameTy {symbol=sym; pos} ->
379 env_get_typ ~sym ~env ~pos
380 | A.RecordTy fields ->
382 List.map fields ~f:(fun (A.Field {name; escape=_; typ; pos}) ->
383 let ty = env_get_typ ~sym:typ ~env ~pos in
387 Type.new_record fields
388 | A.ArrayTy {symbol=sym; pos} ->
389 let element_ty = env_get_typ ~sym ~env ~pos in
390 Type.new_array element_ty
396 let transProg absyn =
397 let {exp = _; ty = _} = transExp absyn ~env:Env.base in