(* types.rml *)

module Types:
    with "absyn.rml"    (* import RelOp and BinOp *)
    with "tcode.rml"

(* Type representation in module Types, used for environments and type
 analysis *)
    type Ident          = string
    type Stamp          = int

    datatype ATy        = CHAR | INT | REAL

    datatype Ty         = ARITH of ATy
                        | PTR of Ty
                        | PTRNIL         
                        | ARR of int * Ty
                        | REC of Record
                        | UNFOLD of Stamp
    and Record          = RECORD of Stamp * (Ident * Ty) list

    (* inspect a record by unfolding it one level *)
    relation unfold_rec:Record => (Ident * Ty) list

    (* convert our types to TCode types *)
    relation ty_cnv:    Ty => TCode.Ty
    relation rec_cnv:   Record => TCode.Record

    (* apply usual rvalue decay to exp:ty *)
    relation decay:     (TCode.Exp, Ty) => (TCode.Exp, Ty)

    (* apply the assignment conversions to an rvalue *)
    relation asg_cnv:   (TCode.Exp, Ty, Ty) => TCode.Exp

    (* apply the cast conversions to a decayed rvalue *)
    relation cast_cnv:  (TCode.Exp, Ty, Ty) => TCode.Exp

    (* apply the conditional conversions to a decayed rvalue *)
    relation cond_cnv:  (TCode.Exp, Ty) => TCode.Exp

    (* make an equality expression out of two decayed rvalues *)
    relation eq_cnv:    (TCode.Exp, Ty, TCode.Exp, Ty) => TCode.Exp

    (* make a relation expression out of two decayed rvalues *)
    relation rel_cnv:   (TCode.Exp, Ty, Absyn.RelOp, TCode.Exp, Ty)
          => TCode.Exp

    (* make a binary arithmetic expression out of two decayed rvalues *)
    relation bin_cnv: (TCode.Exp,Ty,Absyn.BinOp,TCode.Exp,Ty) => (TCode.Exp,Ty)
end

relation unfold_rec: Record => (Ident * Ty) list   =

  rule  unfold_bnds(r, bnds, []) => bnds'
        ----------------
        unfold_rec(r as RECORD(stamp, bnds)) => bnds'
end

relation unfold_bnds: (Record, (Ident * Ty) list, (Ident * Ty) list)
          => (Ident * Ty) list =
  rule  list_reverse bnds' => bnds''
        ----------------
        unfold_bnds(_, [], bnds') => bnds''

  rule  unfold_ty(ty, r) => ty' &
        unfold_bnds(r, bnds, (id,ty')::bnds') => bnds''
        ----------------
        unfold_bnds(r, (id,ty)::bnds, bnds') => bnds''
end

relation unfold_ty:  (Ty,Record) => Ty   =

  axiom unfold_ty(ty as ARITH _, _) => ty
  axiom unfold_ty(ty as PTRNIL, _) => ty

  rule  unfold_ty(ty, r) => ty'
        ----------------
        unfold_ty(PTR ty, r) => PTR ty'

  rule  unfold_ty(ty, r) => ty'
        ----------------
        unfold_ty(ARR(sz,ty), r) => ARR(sz,ty')

  rule  unfold_bnds(r, bnds, []) => bnds'
        ----------------
        unfold_ty(REC(RECORD(stamp,bnds)), r) => REC(RECORD(stamp,bnds'))

  (* Unfold one level; replace the UNFOLD constructor with a node containing
     a copy of the record declaration itself *)
  rule  stamp = stamp'
        ----------------
        unfold_ty(UNFOLD stamp, r as RECORD(stamp',_)) => REC r

  rule  not stamp = stamp'
        ----------------
        unfold_ty(ty as UNFOLD stamp, RECORD(stamp',_)) => ty
end

relation ty_cnv: Ty => TCode.Ty   =

  axiom ty_cnv(ARITH CHAR)      => TCode.CHAR
  axiom ty_cnv(ARITH INT)       => TCode.INT
  axiom ty_cnv(ARITH REAL)      => TCode.REAL

  rule  ty_cnv ty => ty'
        ----------------
        ty_cnv(PTR ty) => TCode.PTR ty'

  rule  ty_cnv ty => ty'
        ----------------
        ty_cnv(ARR(sz,ty)) => TCode.ARR(sz,ty')

  rule  rec_cnv r => r'
        ----------------
        ty_cnv(REC r) => TCode.REC r'

  axiom ty_cnv(UNFOLD stamp) => TCode.UNFOLD stamp
end

relation rec_cnv: Record => TCode.Record   =
  rule  bnds_cnv(bnds, []) => bnds'
        ----------------
        rec_cnv(RECORD(stamp, bnds)) => TCode.RECORD(stamp, bnds')
end

relation bnds_cnv: ((Ident * Ty) list, TCode.Var list) =>  TCode.Var list   =

  rule  list_reverse bnds' => bnds''
        ----------------
        bnds_cnv([], bnds') => bnds''

  rule  ty_cnv ty => ty' &
        bnds_cnv(bnds, TCode.VAR(var,ty')::bnds') => bnds''
        ----------------
        bnds_cnv((var,ty)::bnds, bnds') => bnds''
end

relation decay: (TCode.Exp, Ty) => (TCode.Exp, Ty)   =

  axiom decay(exp, ARITH CHAR) => (TCode.UNARY(TCode.CtoI,exp), ARITH INT)

  rule  ty_cnv ty => ty'
        ----------------
        decay(exp, ARR(_,ty)) => (TCode.UNARY(TCode.TOPTR ty',exp), PTR ty)

  axiom decay(exp, ty as ARITH INT) => (exp, ty)
  axiom decay(exp, ty as ARITH REAL) => (exp, ty)
  axiom decay(exp, ty as PTR _) => (exp, ty)
  axiom decay(exp, ty as REC _) => (exp, ty)
  axiom decay(exp, ty as PTRNIL) => (exp, ty)

end

relation asg_cnv: (TCode.Exp, Ty, Ty) => TCode.Exp   = 

  rule  asg_cnv'(rhs, aty1, aty2) => rhs'
        ----------------
        asg_cnv(rhs, ARITH aty1, ARITH aty2) => rhs'

  rule  ty1 = ty2
        ----------------
        asg_cnv(rhs, PTR ty1, PTR ty2) => rhs

  rule  ty1 = ty2
        ----------------
        asg_cnv(rhs, ARR(_,ty1), PTR ty2) => rhs

  (* Generic NIL, PTRNIL is converted to a specific NIL (ICON 0) for type ty'*)
  rule  ty_cnv ty => ty'
        ----------------
        asg_cnv(_, PTRNIL, PTR ty) => TCode.UNARY(TCode.TOPTR ty',
                                                  TCode.ICON 0)

  rule  stamp1 = stamp2
        ----------------
        asg_cnv(rhs, REC(RECORD(stamp1,_)), REC(RECORD(stamp2,_))) => rhs
end

relation asg_cnv' :  (TCode.Exp, ATy, ATy) => TCode.Exp   =
  axiom asg_cnv'(rhs,CHAR,CHAR)=> rhs
  axiom asg_cnv'(rhs,CHAR, INT)=> TCode.UNARY(TCode.CtoI, rhs)
  axiom asg_cnv'(rhs,CHAR,REAL)=>
              TCode.UNARY(TCode.ItoR,TCode.UNARY(TCode.CtoI,rhs))
  axiom asg_cnv'(rhs, INT,CHAR)=> TCode.UNARY(TCode.ItoC, rhs)
  axiom asg_cnv'(rhs, INT, INT)=> rhs
  axiom asg_cnv'(rhs, INT,REAL)=> TCode.UNARY(TCode.ItoR, rhs)
  axiom asg_cnv'(rhs,REAL,CHAR)=>
              TCode.UNARY(TCode.ItoC,TCode.UNARY(TCode.RtoI,rhs))
  axiom asg_cnv'(rhs,REAL, INT)=> TCode.UNARY(TCode.RtoI, rhs)
  axiom asg_cnv'(rhs,REAL,REAL)=> rhs
end

relation cast_cnv: (TCode.Exp, Ty, Ty) => TCode.Exp   =

  rule  asg_cnv'(exp, aty1, aty2) => exp'
        ----------------
        cast_cnv(exp, ARITH aty1, ARITH aty2) => exp'

  rule  asg_cnv'(TCode.UNARY(TCode.PtoI,exp), INT, aty) => exp'
        ----------------
        cast_cnv(exp, PTR _, ARITH aty) => exp'

  rule  asg_cnv'(TCode.ICON 0, INT, aty) => exp
        ----------------
        cast_cnv(_, PTRNIL, ARITH aty) => exp

  rule  asg_cnv'(exp, aty1, INT) => exp' &
        ty_cnv ty2 => ty2'
        ----------------
        cast_cnv(exp, ARITH aty1, PTR ty2) => TCode.UNARY(TCode.TOPTR ty2',
                                                          exp')

  rule  ty_cnv ty => ty'
        ----------------
        cast_cnv(exp, PTR _, PTR ty) => TCode.UNARY(TCode.TOPTR ty', exp)

  rule  ty_cnv ty => ty'
        ----------------
        cast_cnv(_, PTRNIL, PTR ty) => TCode.UNARY(TCode.TOPTR ty',
                                                   TCode.ICON 0)
end

(**?? what about AND, OR operators? The relation bin_cnv (called by elab_rvalue) does not seem to apply any conversions to non-boolean values ** note: booleans never exist. and or ar bit pattern operators on integer values).
In the first rule, the type PTRNIL is only used for the generic pointer constant nil, which is represented as the integer zero.
In the second rule, no change is done since the boolean type at this stage is represented as the integer type. Booleans never exist as a separate type in Petrol-they are always represented as integers.
The third rule converts floating point expressions, by inserting tests that equality to floating point zero is false.
Finally, the fourth rule handles pointer expressions similarly by inserting tests that pointer equality to nil is false. The relation ty_cnv is called to provide the TCode type representation needed by the type-parameterized operator PTR. *)
relation cond_cnv: (TCode.Exp, Ty) => TCode.Exp   =

  axiom cond_cnv(_, PTRNIL) => TCode.ICON 0

  axiom cond_cnv(exp, ARITH INT) => exp   (* No change for int, already bool *)

  (* Example: if xreal ..., converted to (xreal=0.0) = False   *)
  axiom cond_cnv(exp, ARITH REAL)
        => TCode.BINARY(TCode.BINARY(exp, TCode.REQ, TCode.RCON 0.0),
                        TCode.IEQ,
                        TCode.ICON 0)

  (* Example: if xptr ..., converted to (xptr=nil) = False *)
  rule  ty_cnv ty => ty'
        ---------------- 
        cond_cnv(exp, PTR ty)
        => TCode.BINARY(TCode.BINARY(exp,
                                     TCode.PEQ ty',
                                     TCode.UNARY(TCode.TOPTR ty',
                                                 TCode.ICON 0)),
                        TCode.IEQ,
                        TCode.ICON 0)
end

relation eq_cnv: (TCode.Exp, Ty, TCode.Exp, Ty) => TCode.Exp   =

  (* Compare two pointers, just require that pointer types are equal *)
  rule  ty1 = ty2 & ty_cnv ty1 => ty'
        ----------------
        eq_cnv(exp1, PTR ty1, exp2, PTR ty2) =>
        TCode.BINARY(exp1,TCode.PEQ ty',exp2)

  (* Special case: compare pointer to nil *)
  rule  ptr_eq_null(exp, ty) => exp'
        ----------------
        eq_cnv(exp, PTR ty, _, PTRNIL) => exp'

  (* Special case: compare nil to pointer *)
  rule  ptr_eq_null(exp, ty) => exp'
        ----------------
        eq_cnv(_, PTRNIL, exp, PTR ty) => exp'

  (* arithmetic case: widen to real if one of them is real *)
  rule  arith_cnv(exp1, raty1, exp2, raty2) => (exp1', exp2', raty3) &
        choose_int_real(raty3, TCode.IEQ, TCode.REQ) => bop
        ----------------
        eq_cnv(exp1, ARITH raty1, exp2, ARITH raty2) =>
        TCode.BINARY(exp1',bop,exp2')
end

relation ptr_eq_null: (TCode.Exp, Ty) => TCode.Exp =
  rule  ty_cnv ty => ty'
        ----------------
        ptr_eq_null(exp, ty) => TCode.BINARY(exp,TCode.PEQ ty',
                                             TCode.UNARY(TCode.TOPTR ty',
                                                         TCode.ICON 0))
end

relation choose_int_real: (ATy,TCode.BinOp,TCode.BinOp) => TCode.BinOp =
  axiom choose_int_real(INT, x, _) => x
  axiom choose_int_real(REAL, _, y) => y
end

relation arith_cnv:  (TCode.Exp,ATy, TCode.Exp,ATy) =>
                                                  (TCode.Exp, TCode.Exp, ATy)  =
  rule  arith_lub(raty1, raty2) => raty3 &
        arith_widen(exp1, raty1, raty3) => exp1' &
        arith_widen(exp2, raty2, raty3) => exp2'
        ----------------
        arith_cnv(exp1, raty1, exp2, raty2) => (exp1', exp2', raty3)
end

relation arith_lub:  (ATy, ATy) => ATy  =
  axiom arith_lub(INT, y)       => y
  axiom arith_lub(REAL, _)      => REAL
end

relation arith_widen: (TCode.Exp, ATy, ATy) => TCode.Exp  =
  axiom arith_widen(exp, INT, INT) => exp
  axiom arith_widen(exp, INT, REAL) => TCode.UNARY(TCode.ItoR, exp)
  axiom arith_widen(exp, REAL, REAL) => exp
end 

relation rel_cnv: (TCode.Exp, Ty, Absyn.RelOp, TCode.Exp, Ty) => TCode.Exp   =

  rule  ty1 = ty2 &
        ty_cnv ty1 => ty' &
        ptr_relop(relop, ty') => bop
        ----------------
        rel_cnv(exp1, PTR ty1, relop, exp2, PTR ty2)
          => TCode.BINARY(exp1,bop,exp2)

  rule  arith_cnv(exp1, raty1, exp2, raty2) => (exp1', exp2', raty3)  &
        int_or_real_relop(raty3, relop)     => bop
        ----------------
        rel_cnv(exp1,ARITH raty1,relop,exp2,ARITH raty2) => 
        TCode.BINARY(exp1',bop,exp2')
end

relation ptr_relop: (Absyn.RelOp, TCode.Ty) => TCode.BinOp   =
  axiom ptr_relop(Absyn.LT, ty) => TCode.PLT ty
  axiom ptr_relop(Absyn.LE, ty) => TCode.PLE ty
end

relation int_or_real_relop: (ATy, Absyn.RelOp) => TCode.BinOp   =
  axiom int_or_real_relop(INT,  Absyn.LT) => TCode.ILT
  axiom int_or_real_relop(INT,  Absyn.LE) => TCode.ILE
  axiom int_or_real_relop(REAL, Absyn.LT) => TCode.RLT
  axiom int_or_real_relop(REAL, Absyn.LE) => TCode.RLE
end

relation bin_cnv: (TCode.Exp,Ty,Absyn.BinOp,TCode.Exp,Ty) => (TCode.Exp, Ty)  =

  rule  add_cnv(exp1, rty1, exp2, rty2) => (exp3, rty3)
        ----------------
        bin_cnv(exp1, rty1, Absyn.ADD, exp2, rty2) => (exp3, rty3)

  rule  sub_cnv(exp1, rty1, exp2, rty2) => (exp3, rty3)
        ----------------
        bin_cnv(exp1, rty1, Absyn.SUB, exp2, rty2) => (exp3, rty3)

  rule  mul_cnv(exp1, rty1, exp2, rty2) => (exp3, rty3)
        ----------------
        bin_cnv(exp1, rty1, Absyn.MUL, exp2, rty2) => (exp3, rty3)

  rule  rdiv_cnv(exp1, rty1, exp2, rty2) => (exp3, rty3)
        ----------------
        bin_cnv(exp1, rty1, Absyn.RDIV, exp2, rty2) => (exp3, rty3)

  rule  intop_cnv(exp1, rty1, TCode.IDIV, exp2, rty2) => (exp3, rty3)
        ----------------
        bin_cnv(exp1, rty1, Absyn.IDIV, exp2, rty2) => (exp3, rty3)

  rule  intop_cnv(exp1, rty1, TCode.IMOD, exp2, rty2) => (exp3, rty3)
        ----------------
        bin_cnv(exp1, rty1, Absyn.IMOD, exp2, rty2) => (exp3, rty3)

  rule  intop_cnv(exp1, rty1, TCode.IAND, exp2, rty2) => (exp3, rty3)
        ----------------
        bin_cnv(exp1, rty1, Absyn.IAND, exp2, rty2) => (exp3, rty3)

  rule  intop_cnv(exp1, rty1, TCode.IOR, exp2, rty2) => (exp3, rty3)
        ----------------
        bin_cnv(exp1, rty1, Absyn.IOR, exp2, rty2) => (exp3, rty3)
end

relation add_cnv: (TCode.Exp, Ty, TCode.Exp, Ty) => (TCode.Exp, Ty)   =

  (* ptr + arith -> ptr *)
  rule  ptr_add_int_cnv(exp1, ty, ty1, exp2) => (exp3, ty3)
        ----------------
        add_cnv(exp1, ty as PTR ty1, exp2, ARITH INT) => (exp3, ty3)

  (* arith + ptr -> ptr *)
  rule  ptr_add_int_cnv(exp2, ty, ty2, exp1) => (exp3, ty3)
        ----------------
        add_cnv(exp1, ARITH INT, exp2, ty as PTR ty2) => (exp3, ty3)

  (* arith + arith -> arith *)
  rule  arith_cnv(exp1, raty1, exp2, raty2) => (exp1', exp2', raty3) &
        choose_int_real(raty3, TCode.IADD, TCode.RADD) => bop
        ----------------
        add_cnv(exp1, ARITH raty1, exp2, ARITH raty2) =>
                                    (TCode.BINARY(exp1',bop,exp2'), ARITH raty3)
end

relation  ptr_add_int_cnv: (TCode.Exp, Ty, Ty, TCode.Exp)
          => (TCode.Exp, Ty)  =
  rule  ty_cnv ty1 => ty1'
        ----------------
        ptr_add_int_cnv(exp1, ty, ty1, exp2) =>
         (TCode.BINARY(exp1, TCode.PADD ty1', exp2), ty)
end

relation sub_cnv:  (TCode.Exp, Ty, TCode.Exp, Ty) => (TCode.Exp, Ty)  =
  (* ptr - ptr -> arith *)
  rule  ty1 = ty2 & ty_cnv ty1 => ty1'
        ----------------
        sub_cnv(exp1, PTR ty1, exp2, PTR ty2) =>
                         (TCode.BINARY(exp1,TCode.PDIFF ty1',exp2), ARITH INT)

  (* ptr - arith -> ptr *)
  rule  ty_cnv ty1 => ty1'
        ----------------
        sub_cnv(exp1, ty as PTR ty1, exp2, ARITH INT)
        => (TCode.BINARY(exp1,TCode.PSUB ty1',exp2), ty)

  (* Note:  arith - ptr  is not allowed!! *)

  (* arith - arith -> *)
  rule  arith_cnv(exp1, raty1, exp2, raty2) => (exp1', exp2', raty3) &
        choose_int_real(raty3, TCode.ISUB, TCode.RSUB) => bop
        ----------------
        sub_cnv(exp1, ARITH raty1, exp2, ARITH raty2)
        => (TCode.BINARY(exp1',bop,exp2'), ARITH raty3)
end

relation mul_cnv: (TCode.Exp, Ty, TCode.Exp, Ty) => (TCode.Exp, Ty)   =

  rule  arith_cnv(exp1, raty1, exp2, raty2) => (exp1', exp2', raty3) &
        choose_int_real(raty3, TCode.IMUL, TCode.RMUL) => bop
        ----------------
        mul_cnv(exp1, ARITH raty1, exp2, ARITH raty2)
        => (TCode.BINARY(exp1',bop,exp2'), ARITH raty3)
end

relation rdiv_cnv: (TCode.Exp, Ty, TCode.Exp, Ty) => (TCode.Exp, Ty)   =

  rule  arith_widen(exp1, raty1, REAL) => exp1' &
        arith_widen(exp2, raty2, REAL) => exp2'
        ----------------
        rdiv_cnv(exp1, ARITH raty1, exp2, ARITH raty2) => 
                              (TCode.BINARY(exp1',TCode.RDIV,exp2'), ARITH REAL)
end

relation intop_cnv: 
        (TCode.Exp, Ty, TCode.BinOp, TCode.Exp, Ty) => (TCode.Exp, Ty) =

  axiom intop_cnv(exp1, ARITH INT, bop, exp2, ARITH INT) =>
        (TCode.BINARY(exp1,bop,exp2), ARITH INT)
end



