From 523e2b063b9ba20329af61e18dc9a5ccbaca06a0 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Thu, 13 Sep 2018 18:40:01 -0400 Subject: [PATCH] WIP type-checking --- compiler/src/lib/tiger/tiger_env_type.ml | 38 ++++- compiler/src/lib/tiger/tiger_env_type.mli | 13 +- compiler/src/lib/tiger/tiger_error.ml | 27 +++ compiler/src/lib/tiger/tiger_error.mli | 8 + compiler/src/lib/tiger/tiger_semant.ml | 193 +++++++++++++++++----- 5 files changed, 230 insertions(+), 49 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_env_type.ml b/compiler/src/lib/tiger/tiger_env_type.ml index 041d421..bb8cdd6 100644 --- a/compiler/src/lib/tiger/tiger_env_type.ml +++ b/compiler/src/lib/tiger/tiger_env_type.ml @@ -15,13 +15,15 @@ type t = | String | Record of { unique : unique - ; fields : (Symbol.t * t) list + ; fields : record_fields } | Array of { unique : unique ; ty : t } | Name of Symbol.t * t option ref +and record_fields = + (Tiger_symbol.t * t) list type env = (Symbol.t, t ) Map.t @@ -50,23 +52,29 @@ let is_equal t1 t2 = * TODO: Can we ignore the warning locally? * *) -let is_record = function +let is_int t = + t = Int + +let is_string t = + t = String + +let is_array = function | Unit | Int | String | Name _ - | Array _ -> false - | Nil (* nil belongs to ANY record *) - | Record _ -> true + | Nil + | Record _ -> false + | Array _ -> true -let is_int = function +let is_record = function | Unit - | Nil + | Int | String | Name _ - | Record _ + | Nil | Array _ -> false - | Int -> true + | Record _ -> true let is_name = function | Unit @@ -77,6 +85,18 @@ let is_name = function | Array _ -> false | Name _ -> true +let if_record t ~f ~otherwise = + match t with + | Record {fields; _} -> + f fields + | Unit + | Int + | String + | Name _ + | Nil + | Array _ -> + otherwise () + let to_string = function | Unit -> "unit" | Nil -> "nil" diff --git a/compiler/src/lib/tiger/tiger_env_type.mli b/compiler/src/lib/tiger/tiger_env_type.mli index 825750c..faeb84a 100644 --- a/compiler/src/lib/tiger/tiger_env_type.mli +++ b/compiler/src/lib/tiger/tiger_env_type.mli @@ -7,13 +7,15 @@ type t = | String | Record of { unique : unique - ; fields : (Tiger_symbol.t * t) list + ; fields : record_fields } | Array of { unique : unique ; ty : t } | Name of Tiger_symbol.t * t option ref +and record_fields = + (Tiger_symbol.t * t) list type env = (Tiger_symbol.t, t ) Tiger_map.t @@ -21,11 +23,16 @@ type env = val built_in : env val is_equal : t -> t -> bool -val is_record : t -> bool + val is_int : t -> bool +val is_string : t -> bool +val is_array : t -> bool +val is_record : t -> bool val is_name : t -> bool -val new_record : (Tiger_symbol.t * t) list -> t +val if_record : t -> f:(record_fields -> 'a) -> otherwise:(unit -> 'a) -> 'a + +val new_record : record_fields -> t val new_array : t -> t val to_string : t -> string diff --git a/compiler/src/lib/tiger/tiger_error.ml b/compiler/src/lib/tiger/tiger_error.ml index ce506d9..782f138 100644 --- a/compiler/src/lib/tiger/tiger_error.ml +++ b/compiler/src/lib/tiger/tiger_error.ml @@ -7,7 +7,15 @@ type t = | Invalid_syntax of Pos.t | Unknown_id of {id : Sym.t; pos : Pos.t} | Unknown_type of {ty_id : Sym.t; pos : Pos.t} + | Id_is_a_function of {id : Sym.t; pos : Pos.t} | Id_not_a_function of {id : Sym.t; pos : Pos.t} + | No_such_field_in_record of {field : Sym.t; record : Typ.t; pos : Pos.t} + | Exp_not_a_record of {ty : Typ.t; pos : Pos.t} + | Wrong_type of + { expected : Typ.t + ; given : Typ.t + ; pos : Pos.t + } | Wrong_type_of_expression_in_var_dec of { var_id : Sym.t ; expected : Typ.t @@ -64,9 +72,24 @@ let to_string = s "Unknown identifier %S in %s" (Sym.to_string id) (Pos.to_string pos) | Unknown_type {ty_id; pos} -> s "Unknown type %S in %s" (Sym.to_string ty_id) (Pos.to_string pos) + | Id_is_a_function {id; pos} -> + s "Identifier %S is a function, it cannot be used as a variable in %s" + (Sym.to_string id) (Pos.to_string pos) | Id_not_a_function {id; pos} -> s "Identifier %S is not a function, it cannot be called in %s" (Sym.to_string id) (Pos.to_string pos) + | No_such_field_in_record {field; record; pos} -> + s "No field %S in record %S in %s" + (Sym.to_string field) (Typ.to_string record) (Pos.to_string pos) + | Exp_not_a_record {ty; pos} -> + s ( "This expression has type %S, it is not a record, it cannot be" + ^^"accessed in %s") + (Typ.to_string ty) (Pos.to_string pos) + | Wrong_type {expected; given; pos} -> + s "Type error: expected: %S, but given: %S, in %s" + (Typ.to_string expected) + (Typ.to_string given) + (Pos.to_string pos) | Wrong_type_of_expression_in_var_dec {var_id; expected; given; pos} -> s ( "Wrong type of expression in declaration of %S. " ^^"Expected: %S, given: %S. In %s") @@ -117,7 +140,11 @@ let is_unknown_id t = true | Invalid_syntax _ | Unknown_type _ + | Id_is_a_function _ | Id_not_a_function _ + | No_such_field_in_record _ + | Exp_not_a_record _ + | Wrong_type _ | Wrong_type_of_expression_in_var_dec _ | Wrong_type_used_as_record _ | Wrong_type_of_field_value _ diff --git a/compiler/src/lib/tiger/tiger_error.mli b/compiler/src/lib/tiger/tiger_error.mli index 84d4317..81a87e8 100644 --- a/compiler/src/lib/tiger/tiger_error.mli +++ b/compiler/src/lib/tiger/tiger_error.mli @@ -7,7 +7,15 @@ type t = | Invalid_syntax of Pos.t | Unknown_id of {id : Sym.t; pos : Pos.t} | Unknown_type of {ty_id : Sym.t; pos : Pos.t} + | Id_is_a_function of {id : Sym.t; pos : Pos.t} | Id_not_a_function of {id : Sym.t; pos : Pos.t} + | No_such_field_in_record of {field : Sym.t; record : Typ.t; pos : Pos.t} + | Exp_not_a_record of {ty : Typ.t; pos : Pos.t} + | Wrong_type of + { expected : Typ.t + ; given : Typ.t + ; pos : Pos.t + } | Wrong_type_of_expression_in_var_dec of { var_id : Sym.t ; expected : Typ.t diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index e47c958..659bb85 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -1,9 +1,8 @@ +module List = ListLabels + module A = Tiger_absyn module Env = Tiger_env module E = Tiger_error -module Map = Tiger_map -module Pos = Tiger_position -module Symbol = Tiger_symbol module Translate = Tiger_translate module Type = Tiger_env_type module Value = Tiger_env_value @@ -32,41 +31,161 @@ end = struct let unimplemented () = failwith "unimplemented" - (* TODO: Perhaps a wrapper for env.get that raises semantic error if not found *) + let return ty = {exp = (); ty} + let return_unit = return Type.Unit + let return_nil = return Type.Nil + let return_int = return Type.Int + let return_string = return Type.String - let transExp ~env:_ exp = - (match exp with - | A.NilExp -> - unimplemented () - | A.IntExp _ -> - unimplemented () - | A.StringExp {string=_; _} -> - unimplemented () - | A.CallExp {func=_; args=_; pos=_} -> - unimplemented () - | A.OpExp {left=_; oper=_; right=_; pos=_} -> - unimplemented () - | A.RecordExp {fields=_; typ=_; pos=_} -> - unimplemented () - | A.SeqExp _ -> - unimplemented () - | A.AssignExp {var=_; exp=_; _} -> - unimplemented () - | A.IfExp {test=_; then'=_; else'=_; _} -> - unimplemented () - | A.WhileExp {test=_; body=_; _} -> - unimplemented () - | A.ForExp {var=_; lo=_; hi=_; body=_; _} -> - unimplemented () - | A.BreakExp _ -> - unimplemented () - | A.LetExp {decs=_; body=_; _} -> - unimplemented () - | A.ArrayExp {typ=_; size=_; init=_; _} -> - unimplemented () - | A.VarExp _ -> - unimplemented () - ) + let env_get_typ ~sym ~env ~pos : Type.t = + match Env.get_typ env sym with + | Some ty -> ty + | None -> E.raise (E.Unknown_type {ty_id=sym; pos}) + + let env_get_val ~sym ~env ~pos : Value.t = + match Env.get_val env sym with + | Some ty -> ty + | None -> E.raise (E.Unknown_id {id=sym; pos}) + + let check_same {exp=_; ty=ty_left} {exp=_; ty=ty_right} ~pos : unit = + if Type.is_equal ty_left ty_right then + () + else + 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 + + let rec transExp ~env exp = + let rec trexp exp = + (match exp with + | A.NilExp -> + return_nil + | A.IntExp _ -> + return_int + | A.StringExp {string=_; _} -> + return_string + | A.CallExp {func=_; args=_; pos=_} -> + unimplemented () + | A.OpExp {oper; left; right; pos} -> + trop oper ~left ~right ~pos + | A.RecordExp {fields=_; typ=_; pos=_} -> + unimplemented () + | A.SeqExp exps -> + (* Ignoring value because we only care if a type-checking exception + * is raised in one of trexp calls: *) + List.iter exps ~f:(fun (exp, _) -> ignore (trexp exp)); + return_unit + | A.AssignExp {var; exp; pos} -> + check_same (trvar var) (trexp exp) ~pos; + (* TODO: Add var->exp to val env? *) + return_unit + | A.IfExp {test; then'; else'; pos} -> + (* test : must be int, because we have no bool *) + (* then : must equal else *) + (* else : must equal then or be None *) + check_int (trexp test) ~pos; + (match (trexp then', else') with + | expty_then, None -> + expty_then + | expty_then, Some else' -> + let expty_else = trexp else' in + check_same expty_then expty_else ~pos; + expty_then + ) + | A.WhileExp {test; body; pos} -> + (* test : must be int, because we have no bool *) + check_int (trexp test) ~pos; + ignore (trexp body); (* Only care if a type-error is raised *) + return_unit + | A.ForExp {var; lo; hi; body; pos; escape=_} -> + check_int (trexp lo) ~pos; + check_int (trexp hi) ~pos; + (* Only care if a type-error is raised *) + ignore (transExp ~env:(Env.set_typ env var Type.Int) body); + return_unit + | A.BreakExp _ -> + return_unit + | A.LetExp {decs=_; body=_; _} -> + unimplemented () + | A.ArrayExp {typ=_; size=_; init=_; _} -> + unimplemented () + | A.VarExp var -> + trvar var + ) + and trvar = + (function + | 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 + ) + | A.FieldVar {var; symbol; pos} -> + let {exp=_; ty} = trvar var in + Type.if_record + ty + ~f:(fun fields -> + (match List.assoc_opt symbol fields with + | None -> + E.raise + (E.No_such_field_in_record {field=symbol; record=ty; pos}) + | Some ty -> + return ty + ) + ) + ~otherwise:(fun () -> E.raise (E.Exp_not_a_record {ty; pos})) + | A.SubscriptVar {var=_; exp=_; pos=_} -> + unimplemented () + ) + and trop oper ~left ~right ~pos = + let expty_left = trexp left in + let expty_right = trexp right in + check_same expty_left expty_right ~pos; + let {exp=_; ty} = expty_left in + let module T = Type in + (match oper with + (* Arithmetic: int *) + | A.PlusOp + | A.MinusOp + | A.TimesOp + | A.DivideOp -> + check_int expty_left ~pos; + return_int + (* Equality: int, string, array, record *) + | A.EqOp + | A.NeqOp -> + if (T.is_int ty) + || (T.is_string ty) + || (T.is_array ty) + || (T.is_record ty) + then + return ty + else + E.raise (E.Invalid_operand_type + { oper + ; valid = ["int"; "string"; "array"; "record"] + ; given = ty + ; pos + }) + (* Order: int, string *) + | A.LtOp + | A.LeOp + | A.GtOp + | A.GeOp -> + if (T.is_int ty) + || (T.is_string ty) + then + return ty + else + E.raise (E.Invalid_operand_type + { oper + ; valid = ["int"; "string"] + ; given = ty + ; pos + }) + ) + in + trexp exp let transVar ~env:_ var = (match var with -- 2.20.1