X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_semant.ml;h=f653e162997edbf72841a880ec30170bcaacc1a1;hb=862e5c05ffb0ec1ea8973af0c3c4384f70790ea3;hp=e372bc71594cee26f8c910765e0cfec17ccd989e;hpb=def58eef7daa1f1a72081baf32d8e388acd9064b;p=tiger.ml.git

diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml
index e372bc7..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
@@ -103,6 +104,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;
@@ -234,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 =
@@ -254,10 +256,31 @@ 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 =
+  and transTy ~(env : Env.t) (typ : A.ty) : Type.t =
     (match typ with
     | A.NameTy {symbol=sym; pos} ->
         env_get_typ ~sym ~env ~pos
@@ -273,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