compiler/src/lib/tiger/tiger_semant.ml

   1 module List = ListLabels
   2
   3 module A         = Tiger_absyn
   4 module Env       = Tiger_env
   5 module E         = Tiger_error
   6 module Translate = Tiger_translate
   7 module Type      = Tiger_env_type
   8 module Value     = Tiger_env_value
   9
  10 (* The only reason for having this seemingly-superfluous inner module is to
  11  * have this nice signature as a summary of what each function does. *)
  12 module Semant : sig
  13   type expty =
  14     { exp : Translate.exp
  15     ; ty  : Type.t
  16     }
  17
  18   (* Violating normal naming convention just to make it easier to follow
  19    * Appel's
  20    *)
  21   val transExp : env:Env.t -> A.exp -> expty
  22   val transVar : env:Env.t -> A.var -> expty
  23   val transDec : env:Env.t -> A.dec -> Env.t
  24   val transTy  : env:Env.t -> A.ty  -> Type.t  (* needs only type env *)
  25 end = struct
  26   type expty =
  27     { exp : Translate.exp
  28     ; ty  : Type.t
  29     }
  30
  31   let unimplemented () =
  32     failwith "unimplemented"
  33
  34   let return ty     = {exp = (); ty}
  35   let return_unit   = return Type.Unit
  36   let return_nil    = return Type.Nil
  37   let return_int    = return Type.Int
  38   let return_string = return Type.String
  39
  40   let env_get_typ ~sym ~env ~pos : Type.t =
  41     match Env.get_typ env sym with
  42     | Some ty -> ty
  43     | None    -> E.raise (E.Unknown_type {ty_id=sym; pos})
  44
  45   let env_get_val ~sym ~env ~pos : Value.t =
  46     match Env.get_val env sym with
  47     | Some ty -> ty
  48     | None    -> E.raise (E.Unknown_id {id=sym; pos})
  49
  50   let check_same {exp=_; ty=ty_left} {exp=_; ty=ty_right} ~pos : unit =
  51     if Type.is_equal ty_left ty_right then
  52       ()
  53     else
  54       E.raise (E.Wrong_type {expected=ty_left; given=ty_right; pos})
  55
  56   let check_int expty ~pos : unit =
  57     check_same {exp=(); ty=Type.Int} expty ~pos
  58
  59   let rec transExp ~env exp =
  60     let rec trexp exp =
  61       (match exp with
  62       | A.NilExp ->
  63           return_nil
  64       | A.IntExp _ ->
  65           return_int
  66       | A.StringExp {string=_; _} ->
  67           return_string
  68       | A.CallExp {func=_; args=_; pos=_} ->
  69           unimplemented ()
  70       | A.OpExp {oper; left; right; pos} ->
  71           trop oper ~left ~right ~pos
  72       | A.RecordExp {fields=_; typ=_; pos=_} ->
  73           unimplemented ()
  74       | A.SeqExp exps ->
  75           (* Ignoring value because we only care if a type-checking exception
  76            * is raised in one of trexp calls: *)
  77           List.iter exps ~f:(fun (exp, _) -> ignore (trexp exp));
  78           return_unit
  79       | A.AssignExp {var; exp; pos} ->
  80           check_same (trvar var) (trexp exp) ~pos;
  81           (* TODO: Add var->exp to val env? *)
  82           return_unit
  83       | A.IfExp {test; then'; else'; pos} ->
  84           (* test : must be int, because we have no bool *)
  85           (* then : must equal else *)
  86           (* else : must equal then or be None *)
  87           check_int (trexp test) ~pos;
  88           (match (trexp then', else') with
  89           | expty_then, None ->
  90               expty_then
  91           | expty_then, Some else' ->
  92               let expty_else = trexp else' in
  93               check_same expty_then expty_else ~pos;
  94               expty_then
  95           )
  96       | A.WhileExp {test; body; pos} ->
  97           (* test : must be int, because we have no bool *)
  98           check_int (trexp test) ~pos;
  99           ignore (trexp body);  (* Only care if a type-error is raised *)
 100           return_unit
 101       | A.ForExp {var; lo; hi; body; pos; escape=_} ->
 102           check_int (trexp lo) ~pos;
 103           check_int (trexp hi) ~pos;
 104           (* Only care if a type-error is raised *)
 105           ignore (transExp ~env:(Env.set_typ env var Type.Int) body);
 106           return_unit
 107       | A.BreakExp _ ->
 108           return_unit
 109       | A.LetExp {decs=_; body=_; _} ->
 110           unimplemented ()
 111       | A.ArrayExp {typ=_; size=_; init=_; _} ->
 112           unimplemented ()
 113       | A.VarExp var ->
 114           trvar var
 115       )
 116     and trvar =
 117       (function
 118       | A.SimpleVar {symbol=sym; pos} ->
 119           (match env_get_val ~sym ~env ~pos with
 120           | Value.Fun _    -> E.raise (E.Id_is_a_function {id=sym; pos})
 121           | Value.Var {ty} -> return ty
 122           )
 123       | A.FieldVar {var; symbol; pos} ->
 124           let {exp=_; ty} = trvar var in
 125           Type.if_record
 126             ty
 127             ~f:(fun fields ->
 128               (match List.assoc_opt symbol fields with
 129               | None ->
 130                   E.raise
 131                     (E.No_such_field_in_record {field=symbol; record=ty; pos})
 132               | Some ty ->
 133                   return ty
 134               )
 135             )
 136             ~otherwise:(fun () -> E.raise (E.Exp_not_a_record {ty; pos}))
 137       | A.SubscriptVar {var=_; exp=_; pos=_} ->
 138           unimplemented ()
 139       )
 140     and trop oper ~left ~right ~pos =
 141       let expty_left  = trexp left in
 142       let expty_right = trexp right in
 143       check_same expty_left expty_right ~pos;
 144       let {exp=_; ty} = expty_left in
 145       let module T = Type in
 146       (match oper with
 147       (* Arithmetic: int *)
 148       | A.PlusOp
 149       | A.MinusOp
 150       | A.TimesOp
 151       | A.DivideOp ->
 152           check_int expty_left ~pos;
 153           return_int
 154       (* Equality: int, string, array, record *)
 155       | A.EqOp
 156       | A.NeqOp ->
 157           if (T.is_int    ty)
 158           || (T.is_string ty)
 159           || (T.is_array  ty)
 160           || (T.is_record ty)
 161           then
 162             return ty
 163           else
 164             E.raise (E.Invalid_operand_type
 165               { oper
 166               ; valid = ["int"; "string"; "array"; "record"]
 167               ; given = ty
 168               ; pos
 169               })
 170       (* Order: int, string *)
 171       | A.LtOp
 172       | A.LeOp
 173       | A.GtOp
 174       | A.GeOp ->
 175           if (T.is_int    ty)
 176           || (T.is_string ty)
 177           then
 178             return ty
 179           else
 180             E.raise (E.Invalid_operand_type
 181               { oper
 182               ; valid = ["int"; "string"]
 183               ; given = ty
 184               ; pos
 185               })
 186       )
 187     in
 188     trexp exp
 189
 190   let transVar ~env:_ var =
 191     (match var with
 192     | A.SimpleVar {symbol=_; _} ->
 193         unimplemented ()
 194     | A.FieldVar {var=_; symbol=_; _} ->
 195         unimplemented ()
 196     | A.SubscriptVar {var=_; exp=_; _} ->
 197         unimplemented ()
 198     )
 199
 200   let transDec ~env:_ dec =
 201     (match dec with
 202     | A.VarDec {name=_; typ=_; init=_; pos=_; escape=_} ->
 203         unimplemented ()
 204     | A.TypeDecs _ ->
 205         unimplemented ()
 206     | A.FunDecs _ ->
 207         unimplemented ()
 208     )
 209
 210   let transTy ~env:_ typ =
 211     (match typ with
 212     | A.NameTy {symbol = _; pos = _} ->
 213         unimplemented ()
 214     | A.RecordTy _ ->
 215         unimplemented ()
 216     | A.ArrayTy {symbol = _; pos = _} ->
 217         unimplemented ()
 218     )
 219 end
 220
 221 let transProg absyn =
 222   let open Semant in
 223   let {exp = _; ty = _} = transExp absyn ~env:Env.base in
 224   ()