From cbb4ffb6428f52eaea42f6039332af0c392cdd0f Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Sun, 16 Sep 2018 19:27:18 -0400 Subject: [PATCH] WIP type-checking -- check recursive type defs --- compiler/src/lib/tiger/tiger_env_type.ml | 3 + compiler/src/lib/tiger/tiger_semant.ml | 94 +++++++++++++++------- compiler/src/lib/tiger/tiger_symbol.ml | 3 + compiler/src/lib/tiger/tiger_symbol.mli | 2 + compiler/src/lib/tiger/tiger_test_cases.ml | 26 +++--- 5 files changed, 84 insertions(+), 44 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_env_type.ml b/compiler/src/lib/tiger/tiger_env_type.ml index 4d99a0d..a2e719f 100644 --- a/compiler/src/lib/tiger/tiger_env_type.ml +++ b/compiler/src/lib/tiger/tiger_env_type.ml @@ -45,7 +45,10 @@ let new_array ty = let is_equal t1 t2 = match t1, t2 with + | Name (s1, _) , Name (s2, _) -> Symbol.is_equal s1 s2 | Record {unique=u1; _}, Record {unique=u2; _} -> u1 == u2 + | Record _ , Nil -> true + | Nil , Record _ -> true | Array {unique=u1; _}, Array {unique=u2; _} -> u1 == u2 | t1 , t2 -> t1 = t2 (* The above pattern matching is "fragile" and I'm OK with it. diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index 70639e9..8d0ca11 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -3,6 +3,7 @@ module List = ListLabels module A = Tiger_absyn module Env = Tiger_env module E = Tiger_error +module Symbol = Tiger_symbol module Translate = Tiger_translate module Type = Tiger_env_type module Value = Tiger_env_value @@ -32,6 +33,23 @@ end = struct ; ty : Type.t } + let rec actual_ty ty ~pos = + match ty with + | Type.Name (name, ty_opt_ref) -> + (match !ty_opt_ref with + | None -> + E.raise (E.Unknown_type {ty_id=name; pos}) + | Some ty -> + actual_ty ty ~pos + ) + | Type.Unit + | Type.Nil + | Type.Int + | Type.String + | Type.Record _ + | Type.Array _ -> + ty + let return ty = {exp = (); ty} let return_unit = return Type.Unit let return_nil = return Type.Nil @@ -43,6 +61,9 @@ end = struct | Some ty -> ty | None -> E.raise (E.Unknown_type {ty_id=sym; pos}) + let env_get_typ_actual ~sym ~env ~pos : Type.t = + actual_ty (env_get_typ ~sym ~env ~pos) ~pos + let env_get_val ~sym ~env ~pos : Value.t = match Env.get_val env sym with | Some ty -> ty @@ -55,10 +76,7 @@ end = struct E.raise (E.Wrong_type {expected=ty_left; given=ty_right; pos}) let check_int expty ~pos : unit = - check_same {exp=(); ty=Type.Int} expty ~pos - - (* TODO: actual_ty *) - (* TODO: mutual recursion *) + check_same return_int expty ~pos let rec transExp ~env exp = let rec trexp exp = @@ -73,23 +91,23 @@ end = struct (match env_get_val ~sym:func ~env ~pos with | Value.Fun {formals; result} -> List.iter2 formals args ~f:(fun ty_expected exp_given -> - check_same {exp=(); ty = ty_expected} (trexp exp_given) ~pos; + check_same (return (actual_ty ~pos ty_expected)) (trexp exp_given) ~pos; ); - return result + return (actual_ty ~pos result) | Value.Var _ -> E.raise (E.Id_not_a_function {id=func; pos}) ) | A.OpExp {oper; left; right; pos} -> trop oper ~left ~right ~pos | A.RecordExp {fields=field_exps; typ; pos} -> - let ty = env_get_typ ~sym:typ ~env ~pos in + let ty = env_get_typ_actual ~sym:typ ~env ~pos in Type.if_record ty ~f:(fun field_tys -> List.iter field_exps ~f:(fun (field, exp, pos) -> (match List.assoc_opt field field_tys with | Some field_ty -> - check_same {exp=(); ty=field_ty} (trexp exp) ~pos + check_same (return (actual_ty ~pos field_ty)) (trexp exp) ~pos | None -> E.raise (E.No_such_field_in_record {field; record=ty; pos}) @@ -99,7 +117,7 @@ end = struct ~otherwise:(fun () -> E.raise (E.Wrong_type_used_as_record {ty_id=typ; ty; pos}) ); - return ty + return (actual_ty ~pos ty) | A.SeqExp [] -> return_unit | A.SeqExp exps -> @@ -109,9 +127,8 @@ end = struct |> List.hd (* Empty is matched in above SeqExp match case *) in exps - |> List.map ~f:(fun (exp, _) -> let {ty; _} = trexp exp in ty) + |> List.map ~f:(fun (exp, _) -> trexp exp) |> last - |> return | A.AssignExp {var; exp; pos} -> check_same (trvar var) (trexp exp) ~pos; (* TODO: Add var->exp to val env? *) @@ -152,16 +169,16 @@ end = struct transExp body ~env | A.ArrayExp {typ; size; init; pos} -> check_int (trexp size) ~pos; - let ty = env_get_typ ~sym:typ ~env ~pos in + let ty = env_get_typ_actual ~sym:typ ~env ~pos in Type.if_array ty ~f:(fun ty_elements -> - check_same {exp=(); ty=ty_elements} (trexp init) ~pos + check_same (return (actual_ty ~pos ty_elements)) (trexp init) ~pos ) ~otherwise:(fun () -> E.raise (E.Wrong_type_used_as_array {ty_id=typ; ty; pos}) ); - return ty + return (actual_ty ~pos ty) | A.VarExp var -> trvar var ) @@ -170,7 +187,7 @@ end = struct | A.SimpleVar {symbol=sym; pos} -> (match env_get_val ~sym ~env ~pos with | Value.Fun _ -> E.raise (E.Id_is_a_function {id=sym; pos}) - | Value.Var {ty} -> return ty + | Value.Var {ty} -> return (actual_ty ~pos ty) ) | A.FieldVar {var; symbol; pos} -> let {exp=_; ty} = trvar var in @@ -182,7 +199,7 @@ end = struct E.raise (E.No_such_field_in_record {field=symbol; record=ty; pos}) | Some ty -> - return ty + return (actual_ty ~pos ty) ) ) ~otherwise:(fun () -> E.raise (E.Exp_not_a_record {ty; pos})) @@ -191,10 +208,11 @@ end = struct check_int (trexp exp) ~pos; Type.if_array ty - ~f:(fun ty_elements -> return ty_elements) + ~f:(fun ty_elements -> return (actual_ty ~pos ty_elements)) ~otherwise:(fun () -> E.raise (E.Exp_not_an_array {ty; pos})) ) and trop oper ~left ~right ~pos = + (* TODO: Refactor trop - all opers return bool/int *) let expty_left = trexp left in let expty_right = trexp right in check_same expty_left expty_right ~pos; @@ -216,7 +234,7 @@ end = struct || (T.is_array ty) || (T.is_record ty) then - return ty + return_int (* Because we have no bool type *) else E.raise (E.Invalid_operand_type { oper @@ -232,7 +250,7 @@ end = struct if (T.is_int ty) || (T.is_string ty) then - return ty + return_int (* Because we have no bool type *) else E.raise (E.Invalid_operand_type { oper @@ -251,25 +269,41 @@ end = struct | None, {ty; exp=()} -> ty | Some (sym, pos_inner), expty_init -> - let ty = env_get_typ ~sym ~env ~pos:pos_inner in - check_same {exp=(); ty} expty_init ~pos:pos_outter; + let ty = env_get_typ_actual ~sym ~env ~pos:pos_inner in + check_same (return ty) expty_init ~pos:pos_outter; ty ) in Env.set_val env name (Value.Var {ty}) | A.TypeDecs typedecs -> - List.fold_left typedecs ~init:env ~f:( - fun env (A.TypeDec {name; ty; pos=_}) -> - let ty = transTy ~env ty in - Env.set_typ env name ty - ) + let env = + List.fold_left typedecs ~init:env ~f:( + fun env (A.TypeDec {name; ty=_; pos=_}) -> + Env.set_typ env name (Type.Name (name, ref None)) + ) + in + List.iter typedecs ~f:(fun (A.TypeDec {name; ty=ty_exp; pos}) -> + let ty = transTy ~env ty_exp in + (match env_get_typ ~sym:name ~env ~pos with + | Type.Name (name, ty_opt_ref) -> + ty_opt_ref := Some ty + | Type.Unit + | Type.Nil + | Type.Int + | Type.String + | Type.Record _ + | Type.Array _ -> + () + ) + ); + env | A.FunDecs fundecs -> List.fold_left fundecs ~init:env ~f:( fun env (A.FunDec {name; params; result; body; pos=_}) -> let (env_for_body, formals_in_reverse_order) = List.fold_left params ~init:(env, []) ~f:( fun (env, formals) (A.Field {name; escape=_; typ; pos}) -> - let ty = env_get_typ ~env ~sym:typ ~pos in + let ty = env_get_typ_actual ~env ~sym:typ ~pos in let env = Env.set_val env name (Value.Var {ty}) in (env, ty :: formals) ) @@ -282,13 +316,13 @@ end = struct | None -> Type.Unit | Some (sym, pos) -> - env_get_typ ~sym ~env ~pos + env_get_typ_actual ~sym ~env ~pos in Env.set_val env name (Value.Fun {formals; result}) ) ) - and transTy ~(env : Env.t) (typ : A.ty) : Type.t = - (match typ with + and transTy ~(env : Env.t) (ty_exp : A.ty) : Type.t = + (match ty_exp with | A.NameTy {symbol=sym; pos} -> env_get_typ ~sym ~env ~pos | A.RecordTy fields -> diff --git a/compiler/src/lib/tiger/tiger_symbol.ml b/compiler/src/lib/tiger/tiger_symbol.ml index eb32942..f1dc51a 100644 --- a/compiler/src/lib/tiger/tiger_symbol.ml +++ b/compiler/src/lib/tiger/tiger_symbol.ml @@ -21,3 +21,6 @@ let of_string name = let to_string {name; _} = name + +let is_equal {symbol=s1; _} {symbol=s2; _} = + s1 = s2 diff --git a/compiler/src/lib/tiger/tiger_symbol.mli b/compiler/src/lib/tiger/tiger_symbol.mli index 8605047..e5c560f 100644 --- a/compiler/src/lib/tiger/tiger_symbol.mli +++ b/compiler/src/lib/tiger/tiger_symbol.mli @@ -3,3 +3,5 @@ type t val of_string : string -> t val to_string : t -> string + +val is_equal : t -> t -> bool diff --git a/compiler/src/lib/tiger/tiger_test_cases.ml b/compiler/src/lib/tiger/tiger_test_cases.ml index 8169083..73b1a26 100644 --- a/compiler/src/lib/tiger/tiger_test_cases.ml +++ b/compiler/src/lib/tiger/tiger_test_cases.ml @@ -55,21 +55,19 @@ let micro = (Some [ID "f"; LPAREN; STRING "a"; COMMA; INT 3; COMMA; ID "foo"; RPAREN]) ~is_error_expected_semant:(Some Error.is_unknown_id) ) - ; ( let code = - "let \ - type a = int \ - type b = a \ - type c = b \ - var i : a := 2 \ - var j : c := 3 \ - in \ - i := j \ - end \ - " - in - Test.case + ; ( Test.case "Type aliases" - ~code + ~code: + "let \ + type a = int \ + type b = a \ + type c = b \ + var i : a := 2 \ + var j : c := 3 \ + in \ + i := j \ + end \ + " ) ; ( let code = "let \ -- 2.20.1