WIP type-checking -- check function declarations

[tiger.ml.git] / compiler / src / lib / tiger / tiger_semant.ml

diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml
index 0258351..a0fdf3d 100644 (file)
--- 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 =
@@ -102,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;
@@ -247,10 +249,51 @@ end = struct
           )
         in
         Env.set_val env name (Value.Var {ty})
-    | A.TypeDecs _ ->
-        unimplemented ()
-    | A.FunDecs _ ->
-        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 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
+    | 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 =
@@ -262,16 +305,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