(* types.rml *)
module Types:
    with "absyn.rml"	(* import RelOp and BinOp *)
    with "tcode.rml"
    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
    datatype Record	= RECORD of Stamp * (Ident * Ty) list
    (* An lvalue type (lty) can be any type, except PTRNIL.
       PTR, ARR, and REC can only refer to lvalue types.
       UNFOLD is an internal placeholder that should never
       occur outside of a REC. *)

    (* 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

(* Inspect a record by unfolding it one level
 *)
relation unfold_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'))

  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 unfold_bnds =
  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_rec =
  rule	unfold_bnds(r, bnds, []) => bnds'
	----------------
	unfold_rec(r as RECORD(stamp, bnds)) => bnds'
end

(* Convert one of our types to a TCode type.
 * PTRNIL is intentionally excluded.
 *)
relation ty_cnv =
  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 =
  rule	bnds_cnv(bnds, []) => bnds'
	----------------
	rec_cnv(RECORD(stamp, bnds)) => TCode.RECORD(stamp, bnds')
end

relation bnds_cnv =
  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

(* Apply the usual CHAR->INT and ARR->PTR decay
 * to an rvalue.
 *)
relation decay =
  axiom decay(exp, ARITH CHAR) => (TCode.UNARY(TCode.CtoI,exp), ARITH INT)
  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)

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

(* Convert the rhs of an assignment to the type of the lhs.
 * Ditto for return <exp>.
 * Arithmetic types are widened or narrowed as necessary.
 * The generic null pointer is made type-specific.
 *)
relation asg_cnv' =
  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 asg_cnv = (* rhs, rty, lty => rhs' *)
  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

  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 cast_cnv =
  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

(* Convert a decayed rvalue to a boolean:
 * reals are compared with zero: x != 0.0, i.e. (x == 0.0) == 0
 * pointers are compared with null: p != <nil>, i.e. (p == <nil>) == 0
 *)
relation cond_cnv =
  axiom	cond_cnv(_, PTRNIL) => TCode.ICON 0
  axiom	cond_cnv(exp, ARITH INT) => exp
  axiom	cond_cnv(exp, ARITH REAL)
	=> TCode.BINARY(TCode.BINARY(exp, TCode.REQ, TCode.RCON 0.0),
			TCode.IEQ,
			TCode.ICON 0)

  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

(* Compute the least upper bound of two decayed arithmetic rvalue types
 *)
relation arith_lub =
  axiom arith_lub(INT, y)	=> y
  axiom arith_lub(REAL, _)	=> REAL
end

(* Widen a decayed arithmetic rvalue
 *)
relation arith_widen =
  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

(* Usual arithmetic conversions.
 * Widen two decayed arithmetic rvalues to their lub.
 *)
relation arith_cnv =
  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

(* Elaborate an equality expression.
 * The arguments are already elaborated as decayed rvalues.
 * Make arguments compatible, if necessary by arithmetic widening
 * or instantiation of the polymorphic nil pointer.
 * Return elaborated expression. Result type always int.
 * Equality of records is not defined.
 *)
relation choose_int_real =
  axiom	choose_int_real(INT, x, _) => x
  axiom	choose_int_real(REAL, _, y) => y
end

relation ptr_eq_null =
  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 eq_cnv =
  rule	ty1 = ty2 & ty_cnv ty1 => ty'
	----------------
	eq_cnv(exp1, PTR ty1, exp2, PTR ty2) => TCode.BINARY(exp1,TCode.PEQ ty',exp2)

  rule	ptr_eq_null(exp, ty) => exp'
	----------------
	eq_cnv(exp, PTR ty, _, PTRNIL) => exp'

  rule	ptr_eq_null(exp, ty) => exp'
	----------------
	eq_cnv(_, PTRNIL, exp, PTR ty) => exp'

  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

(* Elaborate a relation expression.
 * The arguments are already elaborated as decayed rvalues.
 * Make arguments compatible, if necessary by arithmetic widening.
 * Choose int, real, or ptr/ptr version of relation operator.
 * Return elaborated expression. Result type always int.
 *)
relation ptr_relop =
  axiom	ptr_relop(Absyn.LT, ty) => TCode.PLT ty
  axiom	ptr_relop(Absyn.LE, ty) => TCode.PLE ty
end

relation int_relop =
  axiom int_relop Absyn.LT => TCode.ILT
  axiom int_relop Absyn.LE => TCode.ILE
end

relation real_relop =
  axiom real_relop Absyn.LT => TCode.RLT
  axiom real_relop Absyn.LE => TCode.RLE
end

relation int_or_real_relop =
  rule	int_relop rop => bop
	----------------
	int_or_real_relop(INT, rop) => bop

  rule	real_relop rop => bop
	----------------
	int_or_real_relop(REAL, rop) => bop
end

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

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

(* Elaborate an addition expression.
 * The arguments are already elaborated as decayed rvalues.
 * Make arguments compatible, if necessary by arithmetic widening.
 * Choose int, real, or ptr/int version of the addition operator.
 * Return elaborated expression and its type.
 *)
relation ptr_add_int_cnv =
  rule	ty_cnv ty1 => ty1'
	----------------
	ptr_add_int_cnv(exp1, ty, ty1, exp2)
	=> (TCode.BINARY(exp1, TCode.PADD ty1', exp2), ty)
end

relation add_cnv =
  rule	ptr_add_int_cnv(exp1, ty, ty1, exp2) => (exp3, ty3)
	----------------
	add_cnv(exp1, ty as PTR ty1, exp2, ARITH INT) => (exp3, ty3)

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

  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

(* Elaborate a subtraction expression.
 * The arguments are already elaborated as decayed rvalues.
 * Make arguments compatible, if necessary by arithmetic widening.
 * Choose int, real, ptr/int, or ptr/ptr version of the subtraction operator.
 * Return elaborated expression and its type.
 *)
relation sub_cnv =
  rule	ty1 = ty2 & ty_cnv ty1 => ty1'
	----------------
	sub_cnv(exp1, PTR ty1, exp2, PTR ty2)
	=> (TCode.BINARY(exp1,TCode.PDIFF ty1',exp2), ARITH INT)

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

  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

(* Elaborate a multiplication expression.
 * The arguments are already elaborated as decayed rvalues.
 * Make arguments compatible, if necessary by arithmetic widening.
 * Choose int or real version of the multiplication operator.
 * Return elaborated expression and its type.
 *)
relation mul_cnv =
  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

(* Elaborate a real division expression.
 * The arguments are already elaborated as decayed rvalues.
 * Widen both arguments to reals.
 * Return elaborated expression and its type (always real).
 *)
relation rdiv_cnv =
  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

(* Elaborate an integer operator expression.
 * The arguments are already elaborated as decayed rvalues.
 * Verify arguments. Return elaborated expression and its type (always int).
 *)
relation intop_cnv =
  axiom intop_cnv(exp1, ARITH INT, bop, exp2, ARITH INT)
	=> (TCode.BINARY(exp1,bop,exp2), ARITH INT)
end

(* Elaborate a binary operator expression.
 * The arguments are already elaborated as decayed rvalues.
 * Return elaborated expression and its type.
 *)
relation bin_cnv =
  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
