WIP type-checking

diff --git a/compiler/src/lib/tiger/tiger_env_type.ml b/compiler/src/lib/tiger/tiger_env_type.ml
index 041d421..bb8cdd6 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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