From 1e835a256b232c01f8af88f78782829764353f70 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Thu, 13 Sep 2018 16:58:23 -0400 Subject: [PATCH 01/16] Abandon -classic-display --- compiler/Makefile | 1 - 1 file changed, 1 deletion(-) diff --git a/compiler/Makefile b/compiler/Makefile index 39be479..20fdb3d 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -7,7 +7,6 @@ OCAMLBUILD_FLAGS_COMP := -cflags '-w A' OCAMLBUILD_FLAGS_YACC := -yaccflag '-v' OCAMLBUILD := \ ocamlbuild \ - -classic-display \ $(OCAMLBUILD_FLAGS_COMP) \ $(OCAMLBUILD_FLAGS_DIRS) \ $(OCAMLBUILD_FLAGS_YACC) -- 2.20.1 From 523e2b063b9ba20329af61e18dc9a5ccbaca06a0 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Thu, 13 Sep 2018 18:40:01 -0400 Subject: [PATCH 02/16] 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 From 161a300dddce2df54b21863ae94e2dda281906fd Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Thu, 13 Sep 2018 18:57:50 -0400 Subject: [PATCH 03/16] WIP type-checking -- check array subscript access --- compiler/src/lib/tiger/tiger_env_type.ml | 12 ++++++++++++ compiler/src/lib/tiger/tiger_env_type.mli | 1 + compiler/src/lib/tiger/tiger_error.ml | 8 +++++++- compiler/src/lib/tiger/tiger_error.mli | 1 + compiler/src/lib/tiger/tiger_semant.ml | 9 +++++++-- 5 files changed, 28 insertions(+), 3 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_env_type.ml b/compiler/src/lib/tiger/tiger_env_type.ml index bb8cdd6..4d99a0d 100644 --- a/compiler/src/lib/tiger/tiger_env_type.ml +++ b/compiler/src/lib/tiger/tiger_env_type.ml @@ -97,6 +97,18 @@ let if_record t ~f ~otherwise = | Array _ -> otherwise () +let if_array t ~f ~otherwise = + match t with + | Array {ty=t; _} -> + f t + | Unit + | Int + | String + | Name _ + | Nil + | Record _ -> + 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 faeb84a..2716e59 100644 --- a/compiler/src/lib/tiger/tiger_env_type.mli +++ b/compiler/src/lib/tiger/tiger_env_type.mli @@ -31,6 +31,7 @@ val is_record : t -> bool val is_name : t -> bool val if_record : t -> f:(record_fields -> 'a) -> otherwise:(unit -> 'a) -> 'a +val if_array : t -> f:(t -> 'a) -> otherwise:(unit -> 'a) -> 'a val new_record : record_fields -> t val new_array : t -> t diff --git a/compiler/src/lib/tiger/tiger_error.ml b/compiler/src/lib/tiger/tiger_error.ml index 782f138..e8af9eb 100644 --- a/compiler/src/lib/tiger/tiger_error.ml +++ b/compiler/src/lib/tiger/tiger_error.ml @@ -11,6 +11,7 @@ type 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} + | Exp_not_an_array of {ty : Typ.t; pos : Pos.t} | Wrong_type of { expected : Typ.t ; given : Typ.t @@ -82,7 +83,11 @@ let to_string = 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" + s ( "The expression of type %S is not a record, it cannot be" + ^^"accessed in %s") + (Typ.to_string ty) (Pos.to_string pos) + | Exp_not_an_array {ty; pos} -> + s ( "The expression of type %S is not an array, it cannot be" ^^"accessed in %s") (Typ.to_string ty) (Pos.to_string pos) | Wrong_type {expected; given; pos} -> @@ -144,6 +149,7 @@ let is_unknown_id t = | Id_not_a_function _ | No_such_field_in_record _ | Exp_not_a_record _ + | Exp_not_an_array _ | Wrong_type _ | Wrong_type_of_expression_in_var_dec _ | Wrong_type_used_as_record _ diff --git a/compiler/src/lib/tiger/tiger_error.mli b/compiler/src/lib/tiger/tiger_error.mli index 81a87e8..92fde5d 100644 --- a/compiler/src/lib/tiger/tiger_error.mli +++ b/compiler/src/lib/tiger/tiger_error.mli @@ -11,6 +11,7 @@ type 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} + | Exp_not_an_array of {ty : Typ.t; pos : Pos.t} | Wrong_type of { expected : Typ.t ; given : Typ.t diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index 659bb85..3265c81 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -134,8 +134,13 @@ end = struct ) ) ~otherwise:(fun () -> E.raise (E.Exp_not_a_record {ty; pos})) - | A.SubscriptVar {var=_; exp=_; pos=_} -> - unimplemented () + | A.SubscriptVar {var; exp; pos} -> + let {exp=_; ty} = trvar var in + check_int (trexp exp) ~pos; + Type.if_array + ty + ~f:(fun ty_elements -> return ty_elements) + ~otherwise:(fun () -> E.raise (E.Exp_not_an_array {ty; pos})) ) and trop oper ~left ~right ~pos = let expty_left = trexp left in -- 2.20.1 From 978cb41cc2a1b976d0e51e52ef76b173f1fba78f Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Thu, 13 Sep 2018 19:15:58 -0400 Subject: [PATCH 04/16] WIP type-checking -- check function call expression --- compiler/src/lib/tiger/tiger_semant.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index 3265c81..40407ef 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -56,6 +56,8 @@ end = struct let check_int expty ~pos : unit = check_same {exp=(); ty=Type.Int} expty ~pos + (* TODO: actual_ty *) + let rec transExp ~env exp = let rec trexp exp = (match exp with @@ -65,8 +67,16 @@ end = struct return_int | A.StringExp {string=_; _} -> return_string - | A.CallExp {func=_; args=_; pos=_} -> - unimplemented () + | A.CallExp {func; args; pos} -> + (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; + ); + return 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=_; typ=_; pos=_} -> -- 2.20.1 From 0ed7a07cf496065c3ff0d0f9325ae8c516b00c1b Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Thu, 13 Sep 2018 19:40:45 -0400 Subject: [PATCH 05/16] WIP type-checking -- check record expressions --- compiler/src/lib/tiger/tiger_semant.ml | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index 40407ef..ca4b489 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -79,8 +79,25 @@ end = struct ) | A.OpExp {oper; left; right; pos} -> trop oper ~left ~right ~pos - | A.RecordExp {fields=_; typ=_; pos=_} -> - unimplemented () + | A.RecordExp {fields=field_exps; typ; pos} -> + let ty = env_get_typ ~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 + | None -> + E.raise + (E.No_such_field_in_record {field; record=ty; pos}) + ) + ) + ) + ~otherwise:(fun () -> + E.raise (E.Wrong_type_used_as_record {ty_id=typ; ty; pos}) + ); + return ty | A.SeqExp exps -> (* Ignoring value because we only care if a type-checking exception * is raised in one of trexp calls: *) -- 2.20.1 From 4c550cd5b9653add413e21d06c73efe3aa657e06 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Thu, 13 Sep 2018 19:54:20 -0400 Subject: [PATCH 06/16] WIP type-checking -- check array expressions --- compiler/src/lib/tiger/tiger_error.ml | 10 ++++++++++ compiler/src/lib/tiger/tiger_error.mli | 5 +++++ compiler/src/lib/tiger/tiger_semant.ml | 14 ++++++++++++-- 3 files changed, 27 insertions(+), 2 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_error.ml b/compiler/src/lib/tiger/tiger_error.ml index e8af9eb..70c3e3c 100644 --- a/compiler/src/lib/tiger/tiger_error.ml +++ b/compiler/src/lib/tiger/tiger_error.ml @@ -28,6 +28,11 @@ type t = ; ty : Typ.t ; pos : Pos.t } + | Wrong_type_used_as_array of + { ty_id : Sym.t + ; ty : Typ.t + ; pos : Pos.t + } | Wrong_type_of_field_value of { field_id : Sym.t ; expected : Typ.t @@ -102,6 +107,10 @@ let to_string = (Typ.to_string expected) (Typ.to_string given) (Pos.to_string pos) + | Wrong_type_used_as_array {ty_id; ty; pos} -> + s ( "Identifier %S is bound to type %S, not an array. " + ^^"It cannot be used in %s") + (Sym.to_string ty_id) (Typ.to_string ty) (Pos.to_string pos) | Wrong_type_used_as_record {ty_id; ty; pos} -> s ( "Identifier %S is bound to type %S, not a record. " ^^"It cannot be used in %s") @@ -152,6 +161,7 @@ let is_unknown_id t = | Exp_not_an_array _ | Wrong_type _ | Wrong_type_of_expression_in_var_dec _ + | Wrong_type_used_as_array _ | Wrong_type_used_as_record _ | Wrong_type_of_field_value _ | Wrong_type_of_arg _ diff --git a/compiler/src/lib/tiger/tiger_error.mli b/compiler/src/lib/tiger/tiger_error.mli index 92fde5d..eba33f2 100644 --- a/compiler/src/lib/tiger/tiger_error.mli +++ b/compiler/src/lib/tiger/tiger_error.mli @@ -28,6 +28,11 @@ type t = ; ty : Typ.t ; pos : Pos.t } + | Wrong_type_used_as_array of + { ty_id : Sym.t + ; ty : Typ.t + ; pos : Pos.t + } | Wrong_type_of_field_value of { field_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 ca4b489..5d5d71b 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -135,8 +135,18 @@ end = struct return_unit | A.LetExp {decs=_; body=_; _} -> unimplemented () - | A.ArrayExp {typ=_; size=_; init=_; _} -> - unimplemented () + | A.ArrayExp {typ; size; init; pos} -> + check_int (trexp size) ~pos; + let ty = env_get_typ ~sym:typ ~env ~pos in + Type.if_array + ty + ~f:(fun ty_elements -> + check_same {exp=(); ty=ty_elements} (trexp init) ~pos + ) + ~otherwise:(fun () -> + E.raise (E.Wrong_type_used_as_array {ty_id=typ; ty; pos}) + ); + return ty | A.VarExp var -> trvar var ) -- 2.20.1 From 8744eb3ab94b939a29d5312c6632595caeccd86c Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 08:31:18 -0400 Subject: [PATCH 07/16] WIP type-checking -- check variable declarations --- compiler/src/lib/tiger/tiger_semant.ml | 41 ++++++++++++++++++-------- 1 file changed, 28 insertions(+), 13 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index 5d5d71b..0258351 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -133,8 +133,13 @@ end = struct return_unit | A.BreakExp _ -> return_unit - | A.LetExp {decs=_; body=_; _} -> - unimplemented () + | A.LetExp {decs; body; pos=_} -> + (* (1) decs augment env *) + (* (2) body checked against the new env *) + let env = + List.fold_left decs ~init:env ~f:(fun env dec -> transDec dec ~env) + in + transExp body ~env | A.ArrayExp {typ; size; init; pos} -> check_int (trexp size) ~pos; let ty = env_get_typ ~sym:typ ~env ~pos in @@ -228,6 +233,25 @@ end = struct ) in trexp exp + and transDec ~env dec = + (match dec with + | A.VarDec {name; typ=typ_opt; init; pos=pos_outter; escape=_} -> + let ty = + (match (typ_opt, transExp ~env init) with + | 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; + ty + ) + in + Env.set_val env name (Value.Var {ty}) + | A.TypeDecs _ -> + unimplemented () + | A.FunDecs _ -> + unimplemented () + ) let transVar ~env:_ var = (match var with @@ -239,16 +263,6 @@ end = struct unimplemented () ) - let transDec ~env:_ dec = - (match dec with - | A.VarDec {name=_; typ=_; init=_; pos=_; escape=_} -> - unimplemented () - | A.TypeDecs _ -> - unimplemented () - | A.FunDecs _ -> - unimplemented () - ) - let transTy ~env:_ typ = (match typ with | A.NameTy {symbol = _; pos = _} -> @@ -260,7 +274,8 @@ end = struct ) end +open Semant + let transProg absyn = - let open Semant in let {exp = _; ty = _} = transExp absyn ~env:Env.base in () -- 2.20.1 From 0f031bf216b72b6d6bbc3941f4244c898f134ce4 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 09:22:31 -0400 Subject: [PATCH 08/16] Count test cases --- compiler/src/lib/tiger/tiger_test.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_test.ml b/compiler/src/lib/tiger/tiger_test.ml index 89376a3..fdab310 100644 --- a/compiler/src/lib/tiger/tiger_test.ml +++ b/compiler/src/lib/tiger/tiger_test.ml @@ -180,6 +180,7 @@ let run tests = let output_value = Some produced in (execution_status, output_status, output_value) in + let test_case_count = ref 0 in List.iter tests ~f:( fun { name @@ -189,6 +190,7 @@ let run tests = ; is_error_expected_semant } -> + incr test_case_count; let (stat_lex_exe, stat_lex_out_cmp, _) = run_pass ~f:pass_lexing @@ -224,9 +226,12 @@ let run tests = ); p "%s" bar_end; p_ln (); p "%s" - (match !failure_count with - | 0 -> status_pass () - | _ -> status_fail () ~info:(s "%d failures" !failure_count) + ( let info = + s "%d failures in %d test cases" !failure_count !test_case_count + in + match !failure_count with + | 0 -> status_pass () ~info + | _ -> status_fail () ~info ); p_ln (); p "%s" bar_end; p_ln (); -- 2.20.1 From 0324a942124e962cba76dbb9985f49ff1fa0960a Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 09:36:42 -0400 Subject: [PATCH 09/16] WIP type-checking -- check type declarations --- compiler/src/lib/tiger/tiger_semant.ml | 34 +++++++++++++++++--------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index 0258351..3a80f21 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -247,11 +247,31 @@ end = struct ) in Env.set_val env name (Value.Var {ty}) - | A.TypeDecs _ -> - unimplemented () + | 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 + ) | A.FunDecs _ -> unimplemented () ) + and transTy ~env typ = + (match typ with + | A.NameTy {symbol=sym; pos} -> + env_get_typ ~sym ~env ~pos + | A.RecordTy fields -> + let fields = + List.map fields ~f:(fun (A.Field {name; escape=_; typ; pos}) -> + let ty = env_get_typ ~sym:typ ~env ~pos in + (name, ty) + ) + in + Type.new_record fields + | A.ArrayTy {symbol=sym; pos} -> + let element_ty = env_get_typ ~sym ~env ~pos in + Type.new_array element_ty + ) let transVar ~env:_ var = (match var with @@ -262,16 +282,6 @@ end = struct | A.SubscriptVar {var=_; exp=_; _} -> unimplemented () ) - - let transTy ~env:_ typ = - (match typ with - | A.NameTy {symbol = _; pos = _} -> - unimplemented () - | A.RecordTy _ -> - unimplemented () - | A.ArrayTy {symbol = _; pos = _} -> - unimplemented () - ) end open Semant -- 2.20.1 From def58eef7daa1f1a72081baf32d8e388acd9064b Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 09:38:02 -0400 Subject: [PATCH 10/16] Add TODO for mutual recursion --- compiler/src/lib/tiger/tiger_semant.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index 3a80f21..e372bc7 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -57,6 +57,7 @@ end = struct check_same {exp=(); ty=Type.Int} expty ~pos (* TODO: actual_ty *) + (* TODO: mutual recursion *) let rec transExp ~env exp = let rec trexp exp = -- 2.20.1 From 76c771a77658a04ddd658455d1c77578d3ff9a79 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 11:01:32 -0400 Subject: [PATCH 11/16] WIP type-checking -- check function declarations --- compiler/src/lib/tiger/tiger_semant.ml | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index e372bc7..a0fdf3d 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -103,6 +103,7 @@ end = struct (* 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)); + (* FIXME: Return type of last expression, not unit. *) return_unit | A.AssignExp {var; exp; pos} -> check_same (trvar var) (trexp exp) ~pos; @@ -254,8 +255,29 @@ end = struct let ty = transTy ~env ty in Env.set_typ env name ty ) - | A.FunDecs _ -> - unimplemented () + | 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 env = Env.set_val env name (Value.Var {ty}) in + (env, ty :: formals) + ) + in + (* ignore because we only care if an exception is raised *) + ignore (transExp ~env:env_for_body body); + let formals = List.rev formals_in_reverse_order in + let result = + match result with + | None -> + Type.Unit + | Some (sym, pos) -> + env_get_typ ~sym ~env ~pos + in + Env.set_val env name (Value.Fun {formals; result}) + ) ) and transTy ~env typ = (match typ with -- 2.20.1 From 862e5c05ffb0ec1ea8973af0c3c4384f70790ea3 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 11:12:52 -0400 Subject: [PATCH 12/16] Remove unused code --- compiler/src/lib/tiger/tiger_semant.ml | 27 +++++++++----------------- 1 file changed, 9 insertions(+), 18 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index a0fdf3d..f653e16 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -19,18 +19,19 @@ module Semant : sig * Appel's *) val transExp : env:Env.t -> A.exp -> expty - val transVar : env:Env.t -> A.var -> expty - val transDec : env:Env.t -> A.dec -> Env.t - val transTy : env:Env.t -> A.ty -> Type.t (* needs only type env *) + + (* transVar does not seem to be needed, as trvar handles all our cases. + * Am I wrong? + * + * val transVar : env:Env.t -> A.var -> expty + * + *) end = struct type expty = { exp : Translate.exp ; ty : Type.t } - let unimplemented () = - failwith "unimplemented" - let return ty = {exp = (); ty} let return_unit = return Type.Unit let return_nil = return Type.Nil @@ -235,7 +236,7 @@ end = struct ) in trexp exp - and transDec ~env dec = + and transDec ~(env : Env.t) (dec : A.dec) : Env.t = (match dec with | A.VarDec {name; typ=typ_opt; init; pos=pos_outter; escape=_} -> let ty = @@ -279,7 +280,7 @@ end = struct Env.set_val env name (Value.Fun {formals; result}) ) ) - and transTy ~env typ = + and transTy ~(env : Env.t) (typ : A.ty) : Type.t = (match typ with | A.NameTy {symbol=sym; pos} -> env_get_typ ~sym ~env ~pos @@ -295,16 +296,6 @@ end = struct let element_ty = env_get_typ ~sym ~env ~pos in Type.new_array element_ty ) - - let transVar ~env:_ var = - (match var with - | A.SimpleVar {symbol=_; _} -> - unimplemented () - | A.FieldVar {var=_; symbol=_; _} -> - unimplemented () - | A.SubscriptVar {var=_; exp=_; _} -> - unimplemented () - ) end open Semant -- 2.20.1 From 155073e21824373c21dacbd75a61623c9d37fff2 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 11:39:57 -0400 Subject: [PATCH 13/16] Tighten-up test cases: specify where errors are expected --- compiler/src/lib/tiger/tiger_error.ml | 44 ++++++++++++++++++++++ compiler/src/lib/tiger/tiger_error.mli | 4 +- compiler/src/lib/tiger/tiger_test_cases.ml | 43 +++++++++++++++------ 3 files changed, 78 insertions(+), 13 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_error.ml b/compiler/src/lib/tiger/tiger_error.ml index 70c3e3c..f49bca4 100644 --- a/compiler/src/lib/tiger/tiger_error.ml +++ b/compiler/src/lib/tiger/tiger_error.ml @@ -169,3 +169,47 @@ let is_unknown_id t = | Invalid_operand_type _ | Different_operand_types _ -> false + +let is_unknown_type t = + match t with + | Unknown_type _ -> + true + | Unknown_id _ + | Invalid_syntax _ + | Id_is_a_function _ + | Id_not_a_function _ + | No_such_field_in_record _ + | Exp_not_a_record _ + | Exp_not_an_array _ + | Wrong_type _ + | Wrong_type_of_expression_in_var_dec _ + | Wrong_type_used_as_array _ + | Wrong_type_used_as_record _ + | Wrong_type_of_field_value _ + | Wrong_type_of_arg _ + | Wrong_number_of_args _ + | Invalid_operand_type _ + | Different_operand_types _ -> + false + +let is_wrong_type t = + match t with + | Wrong_type _ -> + true + | Unknown_type _ + | Unknown_id _ + | Invalid_syntax _ + | Id_is_a_function _ + | Id_not_a_function _ + | No_such_field_in_record _ + | Exp_not_a_record _ + | Exp_not_an_array _ + | Wrong_type_of_expression_in_var_dec _ + | Wrong_type_used_as_array _ + | Wrong_type_used_as_record _ + | Wrong_type_of_field_value _ + | Wrong_type_of_arg _ + | Wrong_number_of_args _ + | Invalid_operand_type _ + | Different_operand_types _ -> + false diff --git a/compiler/src/lib/tiger/tiger_error.mli b/compiler/src/lib/tiger/tiger_error.mli index eba33f2..a9d30eb 100644 --- a/compiler/src/lib/tiger/tiger_error.mli +++ b/compiler/src/lib/tiger/tiger_error.mli @@ -70,4 +70,6 @@ val raise : t -> 'a val to_string : t -> string -val is_unknown_id : t -> bool +val is_unknown_id : t -> bool +val is_unknown_type : t -> bool +val is_wrong_type : t -> bool diff --git a/compiler/src/lib/tiger/tiger_test_cases.ml b/compiler/src/lib/tiger/tiger_test_cases.ml index c7ea1fc..4902017 100644 --- a/compiler/src/lib/tiger/tiger_test_cases.ml +++ b/compiler/src/lib/tiger/tiger_test_cases.ml @@ -131,6 +131,7 @@ let book = [ IF; LPAREN; INT 5; GT; INT 4; RPAREN; THEN; INT 13; ELSE; STRING " " ] ) + ~is_error_expected_semant:Error.is_wrong_type (* TODO: Be more specific *) ; Test.case "Book test: 8-queens" ~code: @@ -190,19 +191,37 @@ let micro = code ~code ~out_lexing:[ID "f"; LPAREN; RPAREN] - ~is_error_expected_semant:Error.is_unknown_id + ~is_error_expected_semant:Error.is_unknown_id (* TODO: Be more specific *) + ) + ; ( let code = "abc.i" in + Test.case + code + ~code + ~out_lexing:[ID "abc"; DOT; ID "i"] + ~is_error_expected_semant:Error.is_unknown_id (* TODO: Be more specific *) + ) + ; ( let code = "abc[0]" in + Test.case + code + ~code + ~out_lexing:[ID "abc"; LBRACK; INT 0; RBRACK] + ~is_error_expected_semant:Error.is_unknown_id (* TODO: Be more specific *) + ) + ; ( let code = "abc[0] := foo()" in + Test.case + code + ~code + ~out_lexing: + [ID "abc"; LBRACK; INT 0; RBRACK; ASSIGN; ID "foo"; LPAREN; RPAREN] + ~is_error_expected_semant:Error.is_unknown_id (* TODO: Be more specific *) + ) + ; ( let code = "abc [5] of nil" in + Test.case + code + ~code + ~out_lexing:[ID "abc"; LBRACK; INT 5; RBRACK; OF; NIL] + ~is_error_expected_semant:Error.is_unknown_type (* TODO: Be more specific *) ) - ; (let code = "abc.i" in Test.case code ~code ~out_lexing:[ID "abc"; DOT; ID "i"]) - ; (let code = "abc[0]" in Test.case code ~code ~out_lexing:[ID "abc"; LBRACK; INT 0; RBRACK]) - - ; (let code = "abc[0] := foo()" in Test.case code ~code - ~out_lexing: - [ID "abc"; LBRACK; INT 0; RBRACK; ASSIGN; ID "foo"; LPAREN; RPAREN]) - - ; (let code = "abc [5] of nil" in Test.case code ~code - ~out_lexing: - [ID "abc"; LBRACK; INT 5; RBRACK; OF; NIL]) - ; ( let code = "f(\"a\", 3, foo)" in Test.case code -- 2.20.1 From 85e08b692d47a78c082e2dd6472062446c2d700b Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 11:45:13 -0400 Subject: [PATCH 14/16] Fix incorrect environment entry should be a value, not type --- compiler/src/lib/tiger/tiger_semant.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index f653e16..082760f 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -132,7 +132,8 @@ end = struct 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); + let env = Env.set_val env var (Value.Var {ty = Type.Int}) in + ignore (transExp ~env body); return_unit | A.BreakExp _ -> return_unit -- 2.20.1 From 9d8471b2ec67822e00009c05a5b5ce9cba57b317 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 12:02:48 -0400 Subject: [PATCH 15/16] Fix use type of last expression in a sequence --- compiler/src/lib/tiger/tiger_semant.ml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index 082760f..70639e9 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -100,12 +100,18 @@ end = struct E.raise (E.Wrong_type_used_as_record {ty_id=typ; ty; pos}) ); return ty - | 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)); - (* FIXME: Return type of last expression, not unit. *) + | A.SeqExp [] -> return_unit + | A.SeqExp exps -> + let last xs = + xs + |> List.rev (* Yes, redundant, but clean-looking ;-P *) + |> List.hd (* Empty is matched in above SeqExp match case *) + in + exps + |> List.map ~f:(fun (exp, _) -> let {ty; _} = trexp exp in ty) + |> last + |> return | A.AssignExp {var; exp; pos} -> check_same (trvar var) (trexp exp) ~pos; (* TODO: Add var->exp to val env? *) -- 2.20.1 From 3be8511c0587d12da978306068c143c71b49f57c Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Fri, 14 Sep 2018 13:55:17 -0400 Subject: [PATCH 16/16] Add a couple of type (in)compatibility test cases --- compiler/src/lib/tiger/tiger_test_cases.ml | 32 ++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/compiler/src/lib/tiger/tiger_test_cases.ml b/compiler/src/lib/tiger/tiger_test_cases.ml index 4902017..bff7efc 100644 --- a/compiler/src/lib/tiger/tiger_test_cases.ml +++ b/compiler/src/lib/tiger/tiger_test_cases.ml @@ -230,6 +230,38 @@ let micro = [ID "f"; LPAREN; STRING "a"; COMMA; INT 3; COMMA; ID "foo"; RPAREN] ~is_error_expected_semant: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 + "Type aliases" + ~code + ) + ; ( let code = + "let + type a = {x:int, y:int} + type b = {x:int, y:int} /* new type generated */ + var foo : a := a {x = 1, y = 2} + var bar : b := b {x = 1, y = 2} + in + foo = bar /* incompatible types */ + end + " + in + Test.case + code + ~code + ~is_error_expected_semant:Error.is_wrong_type (* TODO: Be more specific *) + ) ] let all = -- 2.20.1