1 module List = ListLabels
7 module Escape = Tiger_semant_escape
8 module Pos = Tiger_position
9 module Sym = Tiger_symbol
10 module Temp = Tiger_temp
11 module Translate = Tiger_translate
12 module Type = Tiger_env_type
13 module Value = Tiger_env_value
15 (* The only reason for having this seemingly-superfluous inner module is to
16 * have this nice signature as a summary of what each function does. *)
23 (* Violating normal naming convention just to make it easier to follow
26 val transExp : env:Env.t -> A.exp -> expty
28 (* transVar does not seem to be needed, as trvar handles all our cases.
31 * val transVar : env:Env.t -> A.var -> expty
40 let rec actual_ty ty ~pos =
42 | Type.Name (name, ty_opt_ref) ->
43 (match !ty_opt_ref with
45 E.raise (E.Unknown_type {ty_id=name; pos})
57 let return ty = {exp = Translate.dummy__FIXME; ty}
58 let return_unit = return Type.Unit
59 let return_nil = return Type.Nil
60 let return_int = return Type.Int
61 let return_string = return Type.String
63 let env_get_typ ~sym ~env ~pos : Type.t =
64 match Env.get_typ env sym with
66 | None -> E.raise (E.Unknown_type {ty_id=sym; pos})
68 let env_get_typ_actual ~sym ~env ~pos : Type.t =
69 actual_ty (env_get_typ ~sym ~env ~pos) ~pos
71 let env_get_val ~sym ~env ~pos : Value.t =
72 match Env.get_val env sym with
74 | None -> E.raise (E.Unknown_id {id=sym; pos})
76 let check_same {exp=_; ty=ty_left} {exp=_; ty=ty_right} ~pos : unit =
77 if Type.is_equal ty_left ty_right then
80 E.raise (E.Wrong_type {expected=ty_left; given=ty_right; pos})
82 let check_int expty ~pos : unit =
83 check_same return_int expty ~pos
85 let paths_of_typedecs typedecs : (Sym.t * Sym.t * Pos.t) list list =
87 List.fold_left typedecs ~init:([], []) ~f:(
88 fun (path, paths) (A.TypeDec {name=child; ty; pos}) ->
90 | A.NameTy {symbol=parent; _} ->
91 (((parent, child, pos) :: path), paths)
97 List.map (path :: paths) ~f:List.rev
99 let check_cycles (typedecs : A.typedec list) : unit =
100 let non_empty_paths =
102 (paths_of_typedecs typedecs)
103 ~f:(function [] -> false | _ -> true)
105 List.iter non_empty_paths ~f:(
107 match Dag.of_list (List.map path ~f:(fun (p, c, _) -> (p, c))) with
111 let (_, from_id, from_pos) = List.hd path in
112 let (_, to_id, to_pos) = List.hd (List.rev path) in
113 E.raise (E.Cycle_in_type_decs {from_id; from_pos; to_id; to_pos})
116 let rec transExp ~env exp =
123 | A.StringExp {string=_; _} ->
125 | A.CallExp {func; args; pos} ->
126 (match env_get_val ~sym:func ~env ~pos with
127 | Value.Fun {formals; result; level=_; label=_} ->
128 let expected = List.length formals in
129 let given = List.length args in
130 if given = expected then
132 List.iter2 formals args ~f:(fun ty_expected exp_given ->
134 (return (actual_ty ~pos ty_expected))
138 return (actual_ty ~pos result)
141 E.raise (E.Wrong_number_of_args {func; expected; given; pos})
143 E.raise (E.Id_not_a_function {id=func; pos})
145 | A.OpExp {oper; left; right; pos} ->
146 trop oper ~left ~right ~pos
147 | A.RecordExp {fields=field_exps; typ; pos} ->
148 let ty = env_get_typ_actual ~sym:typ ~env ~pos in
152 List.iter field_exps ~f:(fun (field, exp, pos) ->
153 (match List.assoc_opt field field_tys with
155 check_same (return (actual_ty ~pos field_ty)) (trexp exp) ~pos
158 (E.No_such_field_in_record {field; record=ty; pos})
162 ~otherwise:(fun () ->
163 E.raise (E.Wrong_type_used_as_record {ty_id=typ; ty; pos})
165 return (actual_ty ~pos ty)
171 |> List.rev (* Yes, redundant, but clean-looking ;-P *)
172 |> List.hd (* Empty is matched in above SeqExp match case *)
175 |> List.map ~f:(fun (exp, _) -> trexp exp)
177 | A.AssignExp {var; exp; pos} ->
178 check_same (trvar var) (trexp exp) ~pos;
179 (* TODO: Add var->exp to val env? *)
181 | A.IfExp {test; then'; else'; pos} ->
182 (* test : must be int, because we have no bool *)
183 (* then : must equal else *)
184 (* else : must equal then or be None *)
185 check_int (trexp test) ~pos;
186 (match (trexp then', else') with
187 | expty_then, None ->
189 | expty_then, Some else' ->
190 let expty_else = trexp else' in
191 check_same expty_then expty_else ~pos;
194 | A.WhileExp {test; body; pos} ->
195 (* test : must be int, because we have no bool *)
196 check_int (trexp test) ~pos;
197 let (loop, env) = Env.loop_begin env in
198 (* Only care if an error is raised *)
199 ignore (transExp ~env body);
200 ignore (Env.loop_end env loop);
202 | A.ForExp {var; lo; hi; body; pos; escape=_} ->
203 check_int (trexp lo) ~pos;
204 check_int (trexp hi) ~pos;
205 let (loop, env) = Env.loop_begin env in
206 let level = Env.level_get env in
207 (* Assuming all escape, for now *)
208 let access = Translate.alloc_local ~level ~escapes:true in
209 let env = Env.set_val env var (Value.Var {ty = Type.Int; access}) in
210 (* Only care if an error is raised *)
211 ignore (transExp ~env body);
212 ignore (Env.loop_end env loop);
215 (match Env.loop_current env with
217 | None -> E.raise (E.Break_outside_loop pos)
220 | A.LetExp {decs; body; pos=_} ->
221 (* (1) decs augment env *)
222 (* (2) body checked against the new env *)
224 List.fold_left decs ~init:env ~f:(fun env dec -> transDec dec ~env)
227 | A.ArrayExp {typ; size; init; pos} ->
228 check_int (trexp size) ~pos;
229 let ty = env_get_typ_actual ~sym:typ ~env ~pos in
232 ~f:(fun ty_elements ->
233 check_same (return (actual_ty ~pos ty_elements)) (trexp init) ~pos
235 ~otherwise:(fun () ->
236 E.raise (E.Wrong_type_used_as_array {ty_id=typ; ty; pos})
238 return (actual_ty ~pos ty)
244 | A.SimpleVar {symbol=sym; pos} ->
245 (match env_get_val ~sym ~env ~pos with
247 E.raise (E.Id_is_a_function {id=sym; pos})
248 | Value.Var {ty; access=_} ->
249 return (actual_ty ~pos ty)
251 | A.FieldVar {var; symbol; pos} ->
252 let {exp=_; ty} = trvar var in
256 (match List.assoc_opt symbol fields with
259 (E.No_such_field_in_record {field=symbol; record=ty; pos})
261 return (actual_ty ~pos ty)
264 ~otherwise:(fun () -> E.raise (E.Exp_not_a_record {ty; pos}))
265 | A.SubscriptVar {var; exp; pos} ->
266 let {exp=_; ty} = trvar var in
267 check_int (trexp exp) ~pos;
270 ~f:(fun ty_elements -> return (actual_ty ~pos ty_elements))
271 ~otherwise:(fun () -> E.raise (E.Exp_not_an_array {ty; pos}))
273 and trop oper ~left ~right ~pos =
274 (* TODO: Refactor trop - all opers return bool/int *)
275 let expty_left = trexp left in
276 let expty_right = trexp right in
277 check_same expty_left expty_right ~pos;
278 let {exp=_; ty} = expty_left in
279 let module T = Type in
281 (* Arithmetic: int *)
286 check_int expty_left ~pos;
288 (* Equality: int, string, array, record *)
296 return_int (* Because we have no bool type *)
298 E.raise (E.Invalid_operand_type
300 ; valid = ["int"; "string"; "array"; "record"]
304 (* Order: int, string *)
312 return_int (* Because we have no bool type *)
314 E.raise (E.Invalid_operand_type
316 ; valid = ["int"; "string"]
323 and transDec ~(env : Env.t) (dec : A.dec) : Env.t =
325 | A.VarDec {name; typ=typ_opt; init; pos=pos_outter; escape=_} ->
327 (match (typ_opt, transExp ~env init) with
328 | None, {ty; exp=_} ->
330 | Some (sym, pos_inner), expty_init ->
331 let ty = env_get_typ_actual ~sym ~env ~pos:pos_inner in
332 check_same (return ty) expty_init ~pos:pos_outter;
337 Translate.alloc_local
338 ~level:(Env.level_get env)
339 ~escapes:true (* Assuming all escape, for now... *)
341 Env.set_val env name (Value.Var {ty; access})
342 | A.TypeDecs typedecs ->
343 check_cycles typedecs;
345 List.fold_left typedecs ~init:env ~f:(
346 fun env (A.TypeDec {name; ty=_; pos=_}) ->
347 Env.set_typ env name (Type.Name (name, ref None))
350 List.iter typedecs ~f:(fun (A.TypeDec {name=ty_name; ty=ty_exp; pos}) ->
351 let ty = transTy ~env ~ty_name ~ty_exp in
352 (match env_get_typ ~sym:ty_name ~env ~pos with
353 | Type.Name (_, ty_opt_ref) ->
354 ty_opt_ref := Some ty
365 | A.FunDecs fundecs ->
366 let env_with_fun_heads_only =
367 List.fold_left fundecs ~init:env ~f:(
368 fun env (A.FunDec {name; params; result; body=_; pos=_}) ->
371 fun (A.Field {name=_; typ; pos; escape=_}) ->
372 env_get_typ_actual ~env ~sym:typ ~pos
377 | Some (s, p) -> env_get_typ_actual ~sym:s ~env ~pos:p
380 let label = Temp.Label.gen () in
385 (* Assuming all escape (for now) *)
386 ~formals:(List.map formals ~f:(fun _ -> true))
388 let env = Env.level_set env level in
389 Env.set_val env name (Value.Fun {formals; result; level; label})
392 List.iter fundecs ~f:(
393 fun (A.FunDec {name=_; params; result=_; body; pos=_}) ->
394 let env_with_fun_heads_and_local_vars =
395 List.fold_left params ~init:env_with_fun_heads_only ~f:(
396 fun env (A.Field {name=var_name; escape=_; typ; pos}) ->
397 let var_ty = env_get_typ_actual ~env ~sym:typ ~pos in
398 let level = Env.level_get env in
399 (* Assuming all escape, for now *)
400 let access = Translate.alloc_local ~level ~escapes:true in
404 (Value.Var {ty = var_ty; access})
407 (* we only care if an exception is raised *)
408 ignore (transExp ~env:env_with_fun_heads_and_local_vars body);
410 env_with_fun_heads_only
412 and transTy ~(env : Env.t) ~ty_name ~(ty_exp : A.ty) : Type.t =
414 | A.NameTy {symbol=sym; pos} ->
415 env_get_typ ~sym ~env ~pos
416 | A.RecordTy fields ->
418 List.map fields ~f:(fun (A.Field {name; escape=_; typ; pos}) ->
419 let ty = env_get_typ ~sym:typ ~env ~pos in
423 Type.new_record ~name:ty_name ~fields
424 | A.ArrayTy {symbol=sym; pos} ->
425 let element_ty = env_get_typ ~sym ~env ~pos in
426 Type.new_array ~name:ty_name ~ty:element_ty
432 let transProg absyn =
433 Escape.find ~prog:absyn;
434 let {exp = _; ty = _} = transExp absyn ~env:Env.base in