(* static.rml *)
module Static:
  with "absyn.rml"
  with "tcode.rml"

  relation elaborate: Absyn.Prog => TCode.Prog
end

with "types.rml"

(*
 * Static environment
 *)
datatype Con    = INTcon of int
                | REALcon of real
datatype Bnd    = VARbnd of Types.Ty
                | CONSTbnd of Con
                | FUNCbnd of Types.Ty list * Types.Ty
                | PROCbnd of Types.Ty list
                | TYPEbnd of Types.Ty
                | NILbnd

(* Bnd is just to tag the different type of values that identifiers are
 * associated to,
 * not the binding itself (compare to denotable value in denot. semantics).
 *)

type Ident = string

type Binding    = (TCode.Ident * Bnd)

type Env        = Binding list


val env_init =
[       ("integer",   TYPEbnd(Types.ARITH Types.INT))
,       ("real",      TYPEbnd(Types.ARITH Types.REAL))
,       ("char",      TYPEbnd(Types.ARITH Types.CHAR))
,       ("read",      FUNCbnd([], Types.ARITH Types.INT))
,       ("write",     PROCbnd[Types.ARITH Types.INT])
,       ("trunc",     FUNCbnd([Types.ARITH Types.REAL], Types.ARITH Types.INT))
,       ("nil",       NILbnd)
]

relation map: ('alpha=>'beta, 'alpha list) => 'beta list  =
  axiom map(_, []) => []

  rule  Rfunc x => y & map(Rfunc, xs) => ys
        ----------------
        map(Rfunc, x::xs) => y::ys
end

relation lookup': ((Types.Ident * Types.Ty) list, Absyn.Ident) => Types.Ty =

  rule  key1 = key0
        ----------------
        lookup'((key1,ty)::_, key0) => ty

  rule  not key1 = key0 & lookup'(r, key0) => ty
        ----------------
        lookup'((key1,_)::r, key0) => ty

end

relation lookup: (Env,TCode.Ident) => Bnd  =
  rule  key1 = key0
        ----------------
        lookup((key1,bnd)::_, key0) => bnd

  rule  not key1 = key0 & lookup(env, key0) => bnd
        ----------------
        lookup((key1,_)::env, key0) => bnd
end

relation elab_constant: (Env,Absyn.Constant) => Con   = 
(* Elaborate/evaluate right hand side of const declaration *)

  (* const a = 55 *)
  axiom elab_constant(env, Absyn.INTcon i) => INTcon i

  (* const a = 3.14 *)
  axiom elab_constant(env, Absyn.REALcon r) => REALcon r

  (* const a = b *)
  rule  lookup(env, id) => CONSTbnd c
        ----------------
        elab_constant(env, Absyn.IDENTcon id) => c
end

relation elab_const: (Env,Absyn.ConBnd) => Env   =
(* Enter a const declaration in the environment *)

  rule  elab_constant(env0, c) => con
        ----------------
        elab_const(env0, Absyn.CONBND(id,c)) => ((id,CONSTbnd con)::env0)
end


relation elab_consts: (Env, Absyn.ConBnd list) => Env   = 
(* Enter several constant declarations into the environment *)

  axiom elab_consts(env, []) => env

  rule  elab_const(env, c) => env' &
        elab_consts(env', consts) => env''
        ----------------
        elab_consts(env, c::consts) => env''
end

relation elab_ty:  (Env, Absyn.Ty) => Types.Ty   =
(* Elaborate right hand side of type declaration *)

(* = id *)
  rule  (* print "rule 1\n" & *) lookup(env, id) => TYPEbnd ty'
        ----------------
        elab_ty(env, Absyn.NAME id) => ty'

(* = ^typeexpr, e.g. ^ array [5] of int *)
  rule  (* print "rule 2\n" & *) elab_ty(env, ty) => ty'
        ----------------
        elab_ty(env, Absyn.PTR ty) => Types.PTR ty'


(* = array[c] of ty , c is a constant expr, constliteral or constid *)
  rule  (* print "rule 3\n" & *) elab_constant(env, c) => INTcon sz &
        elab_ty(env, ty) => ty'
        ----------------
        elab_ty(env, Absyn.ARR(c,ty)) => Types.ARR(sz,ty')

(* = record <field_list> end;     
   record binding that contains bnds, a
   list of pairs of field names and types.
   tick is a builtin RML integer generator, that gives new integers 
   stamp is used as a temporary name for the anonymous record type.
   Needed because record decls can be recursive.
   Used to build the internal type representation, similar to the abstract
   syntax, but stamps have been added.
  *)
  rule  print "rule 4\n" & tick => stamp &
        elab_ty_bnds(env, bnds, []) => bnds'
        ----------------
        elab_ty(env, Absyn.REC bnds) => Types.REC(Types.RECORD(stamp, bnds'))

(*a drpo added 2002-03-01 *)
  rule  print "-- elab_ty failed \n"
        ----------------
        elab_ty(_, _) => fail
end


relation elab_ty_bnds: (Env, Absyn.VarBnd list, (Absyn.Ident * Types.Ty) list) => 
(Absyn.Ident * Types.Ty) list  =
(* Map over the list of field bindings in the abstract syntax
 * to give the corresponding list of field bindings in the record type
 * representation.
 * The third parameter accumulates the result list, and is reversed
 * before being returned
 *)

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

  rule  elab_ty(env, ty) => ty' &
        elab_ty_bnds(env, bnds, (id,ty')::bnds') => bnds''
        ----------------
        elab_ty_bnds(env, Absyn.VARBND(id,ty)::bnds, bnds') => bnds''
end

relation elab_types: (Env, Absyn.TyBnd list) => Env   =
  axiom elab_types(env, []) => env

  rule  elab_tybnd(env, tybnd) => env' &
        elab_types(env', tybnds) => env''
        ----------------
        elab_types(env, tybnd::tybnds) => env''
end

relation  elab_tybnd:  (Env, Absyn.TyBnd) => Env   =
  rule  isrec ty => xxx &
        elab_tybnd'(xxx, env0, id) => ty'
        ----------------
        elab_tybnd(env0, Absyn.TYBND(id,ty)) => ((id,TYPEbnd(ty'))::env0)
end

relation elab_tybnd':  (IsRec,Env,Ident) => Types.Ty   =
  rule  tick => stamp &
        elab_ty_bnds((id,TYPEbnd(Types.UNFOLD stamp))::env0,bnds,[]) => bnds' &
        check_bnds(bnds')
        ----------------
        elab_tybnd'(ISREC bnds, env0, id) =>Types.REC(Types.RECORD(stamp,bnds'))

  (* If no record, cannot be recursive, just return elaborated type *)
  rule  elab_ty(env0, ty) => ty'
        ----------------
        elab_tybnd'(NOREC ty, env0, id) => ty'
end

relation check_bnds:  (Ident * Types.Ty) list => ()  =
  axiom check_bnds []

  rule  check_ty ty & check_bnds bnds
        ----------------
        check_bnds((_,ty)::bnds)
end

relation check_ty: Types.Ty => ()   =

  axiom check_ty(Types.ARITH _)

  rule  check_ty ty
        ----------------
        check_ty(Types.ARR(_,ty))

  rule  check_bnds bnds
        ----------------
        check_ty(Types.REC(Types.RECORD(_,bnds)))

  (* require that UNFOLD is preceeded by PTR *)
  rule  isunfold ty => true
        ----------------
        check_ty(Types.PTR ty)

  rule  isunfold ty => false & check_ty ty
        ----------------
        check_ty(Types.PTR ty)
end

relation isunfold: Types.Ty => bool   =
  axiom isunfold(Types.UNFOLD _) => true
  axiom isunfold(Types.ARITH _) => false
  axiom isunfold(Types.PTR _) => false
  axiom isunfold(Types.ARR(_,_)) => false
  axiom isunfold(Types.REC _) => false
end

datatype IsRec = NOREC of Absyn.Ty | ISREC of Absyn.VarBnd list

relation isrec: Absyn.Ty => IsRec =
  axiom isrec(ty as Absyn.NAME _) => NOREC ty
  axiom isrec(ty as Absyn.PTR _) => NOREC ty
  axiom isrec(ty as Absyn.ARR(_,_)) => NOREC ty
  axiom isrec(Absyn.REC bnds) => ISREC bnds
end

relation elab_rvalue:  (Env, Absyn.Exp) => (TCode.Exp, Types.Ty)   =

  axiom elab_rvalue(env, Absyn.INT i) => (TCode.ICON(i), Types.ARITH(Types.INT))

  axiom elab_rvalue(env, Absyn.REAL r) => (TCode.RCON(r), Types.ARITH(Types.REAL))

  rule  lookup(env, id) => bnd  &  rvalue_id(bnd, id) => (exp, ty)
        ----------------                                         (* id *)
        elab_rvalue(env, Absyn.IDENT id) => (exp, ty)

  rule  elab_rvalue_decay(env, exp) => (exp', ty') &
        elab_ty(env, ty) => ty'' &
        Types.cast_cnv(exp', ty', ty'') => exp''
        ----------------                                   (* type cast *)
        elab_rvalue(env,Absyn.CAST(ty,exp)) => (exp'', ty'')

  rule  elab_field(env, exp, id) => (exp', ty) &
        rvalue_var(ty, exp') => (exp'', ty')
        ----------------                             (* fieldref:  exp.id *)
        elab_rvalue(env,Absyn.FIELD(exp,id)) => (exp'', ty')

  rule  elab_unary_rvalue(env, unop, exp) => (exp', rty)
        ----------------                                 (* unop exp *)
        elab_rvalue(env, Absyn.UNARY(unop,exp)) => (exp', rty)

  rule  elab_rvalue_decay(env, exp1) => (exp1', rty1) &
        elab_rvalue_decay(env, exp2) => (exp2', rty2) &
        Types.bin_cnv(exp1', rty1, binop, exp2', rty2) => (exp3, rty3)
        ----------------                              (* exp1 binop exp2 *)
        elab_rvalue(env, Absyn.BINARY(exp1,binop,exp2)) => (exp3, rty3)

  rule  elab_rvalue_decay(env, exp1) => (exp1', rty1) &
        elab_rvalue_decay(env, exp2) => (exp2', rty2) &
        Types.rel_cnv(exp1', rty1, relop, exp2', rty2) => exp3
        ----------------                             (* exp1 relop exp2 *)
        elab_rvalue(env,Absyn.RELATION(exp1,relop,exp2)) =>
                                                      (exp3, Types.ARITH Types.INT)

  rule  elab_rvalue_decay(env, exp1) => (exp1', rty1) &
        elab_rvalue_decay(env, exp2) => (exp2', rty2) &
        Types.eq_cnv(exp1', rty1, exp2', rty2) => exp3
        ----------------                                  (* exp1 = exp2 *)
        elab_rvalue(env, Absyn.EQUALITY(exp1,exp2)) =>
                                                     (exp3, Types.ARITH Types.INT)

  rule  lookup(env, id) => FUNCbnd(argtys,resty) &
        elab_args(env, args, argtys, []) => args'
        ----------------                                    (* func(args) *)
        elab_rvalue(env, Absyn.FCALL(id,args))
          => (TCode.FCALL(id, args'), resty)
end

relation elab_unary_rvalue: (Env,Absyn.UnOp,Absyn.Exp)
          => (TCode.Exp,Types.Ty) =

  rule  elab_lvalue(env, exp) => (exp', ty)
        ----------------
        elab_unary_rvalue(env, Absyn.ADDR, exp) => (exp', Types.PTR ty)

  rule  elab_rvalue_decay(env, exp) => (exp', Types.PTR ty) &
        Types.ty_cnv ty  =>  ty'
        ----------------
        elab_unary_rvalue(env, Absyn.INDIR, exp) =>
                                          (TCode.UNARY(TCode.LOAD ty',exp'),
                                           ty)

  rule  elab_rvalue_decay(env, exp) => (exp', ty) &
        Types.cond_cnv(exp', ty) => exp''
        ----------------
        elab_unary_rvalue(env, Absyn.NOT, exp)
        => (TCode.BINARY(exp'', TCode.IEQ, TCode.ICON 0),
            Types.ARITH Types.INT)
end

relation elab_rvalue_decay: (Env, Absyn.Exp) => (TCode.Exp, Types.Ty)   =
  rule  elab_rvalue(env, exp) => (exp', ty) &
        Types.decay(exp', ty) => (exp'', ty')
        ----------------
        elab_rvalue_decay(env, exp) => (exp'', ty')
end

relation rvalue_id:  (Bnd,Absyn.Ident) => (TCode.Exp, Types.Ty)   = 

  axiom rvalue_id(CONSTbnd(INTcon i), _)
          => (TCode.ICON i, Types.ARITH Types.INT)

  axiom rvalue_id(CONSTbnd(REALcon r),_)
          => (TCode.RCON r, Types.ARITH Types.REAL)

  axiom rvalue_id(NILbnd, _) => (TCode.ICON 0, Types.PTRNIL)

  rule  rvalue_var(ty, TCode.ADDR(id)) => (exp', ty')
        ----------------
        rvalue_id(VARbnd ty, id) => (exp', ty')
end

relation rvalue_var:  (Types.Ty, TCode.Exp) => (TCode.Exp, Types.Ty)  =

  rule  mkload(ty, addr) => exp
        ----------------
        rvalue_var(ty as Types.ARITH _, addr) => (exp, ty)

  rule  mkload(ty, addr) => exp
        ----------------
        rvalue_var(ty as Types.PTR _, addr) => (exp, ty)

  rule  mkload(ty, addr) => exp
        ----------------
        rvalue_var(ty as Types.REC _, addr) => (exp, ty)

  rule  Types.ty_cnv ty => ty'
        ----------------
        rvalue_var(Types.ARR(_,ty), addr)
              => (TCode.UNARY(TCode.TOPTR ty', addr), Types.PTR(ty))
end

relation mkload: (Types.Ty,TCode.Exp) => TCode.Exp   =
  rule  Types.ty_cnv(ty) => ty'
        ----------------
        mkload(ty, addr) => TCode.UNARY(TCode.LOAD(ty'), addr)
end

relation elab_arg: (Env,Absyn.Exp,Types.Ty) => TCode.Exp   =
  rule  elab_rvalue(env, exp) => (exp', ty') &
        Types.asg_cnv(exp', ty', ty) => exp''
        ----------------
        elab_arg(env, exp, ty) => exp''
end

relation elab_args: (Env, Absyn.Exp list, Types.Ty list, TCode.Exp list)
                             => TCode.Exp list    =

  rule  list_reverse args' => args''
        ----------------
        elab_args(_, [], [], args') => args''

  rule  elab_arg(env, exp, ty) => exp' &
        elab_args(env, exps, tys, exp'::exps') => exps''
        ----------------
        elab_args(env, exp::exps, ty::tys, exps') => exps''
end

relation elab_lvalue:  (Env,Absyn.Exp) => (TCode.Exp, Types.Ty)   = 

  rule  lookup(env, id) => VARbnd ty
        ----------------
        elab_lvalue(env, Absyn.IDENT id) => (TCode.ADDR id, ty)

  rule  elab_field(env, exp, id) => (exp', ty)
        ----------------
        elab_lvalue(env, Absyn.FIELD(exp,id)) => (exp', ty)

  rule  elab_rvalue_decay(env, exp) => (exp', Types.PTR ty)
        ----------------
        elab_lvalue(env, Absyn.UNARY(Absyn.INDIR,exp)) => (exp', ty)
end

relation  elab_field:  (Env, Absyn.Exp, Absyn.Ident) => (TCode.Exp, Types.Ty)   =

  rule  elab_lvalue(env, exp) => (exp', Types.REC r) &
        Types.unfold_rec r => bnds & 
        lookup'(bnds, id) => ty &
        Types.rec_cnv r => r'
        ----------------
        elab_field(env, exp, id) => (TCode.UNARY(TCode.OFFSET(r',id),exp'), ty)
end

relation elab_stmt:  (Types.Ty option, Env, Absyn.Stmt) => TCode.Stmt   =

  rule  elab_lvalue(env, lhs) => (lval, lvalty) &
        elab_rvalue(env, rhs) => (rval, rvalty) & 
        Types.asg_cnv(rval, rvalty, lvalty) => rval' &
        Types.ty_cnv lvalty => lvalty'
        ----------------                            (* lhs := rhs; *)
        elab_stmt(fty, env, Absyn.ASSIGN(lhs,rhs)) =>
                                               TCode.STORE(lvalty',lval,rval')

  rule  lookup(env, id) => PROCbnd argtys &
        elab_args(env, args, argtys, []) => args'
        ----------------                            (*  procid(args); *)
        elab_stmt(fty, env, Absyn.PCALL(id,args)) => TCode.PCALL(id, args')

  rule  elab_rvalue(env, exp) => (exp', ety) &
        Types.asg_cnv(exp', ety, rty) => exp'' &
        Types.ty_cnv rty => rty'
        ----------------                          (* return expr *)
        elab_stmt(SOME rty,env,Absyn.FRETURN exp)
          => TCode.RETURN(SOME((rty',exp'')))

  axiom elab_stmt(NONE, env, Absyn.PRETURN) => TCode.RETURN NONE  (* return *)

  rule  elab_rvalue_decay(env, exp) => (exp', ety) &
        Types.cond_cnv(exp', ety) => exp'' &
        elab_stmt(fty, env, stmt) => stmt'
        ----------------                          (* while exp do stmt *)
        elab_stmt(fty, env, Absyn.WHILE(exp,stmt)) => TCode.WHILE(exp'', stmt')

  rule  elab_rvalue_decay(env, exp) => (exp', ety) &
        Types.cond_cnv(exp', ety) => exp'' &
        elab_stmt(fty, env, stmt1) => stmt1' &
        elab_stmt(fty, env, stmt2) => stmt2'
        ----------------           (* if exp then stmt1 else stmt2 end *)
        elab_stmt(fty,env,Absyn.IF(exp,stmt1,stmt2))
          => TCode.IF(exp'',stmt1',stmt2')

  rule  elab_stmt(fty, env, stmt1) => stmt1' &
        elab_stmt(fty, env, stmt2) => stmt2'
        ----------------                       (* stmt1;  stmt2 *)
        elab_stmt(fty, env, Absyn.SEQ(stmt1,stmt2))
          => TCode.SEQ(stmt1', stmt2')

  axiom elab_stmt(fty, env, Absyn.SKIP) => TCode.SKIP  (* empty stmt  ; *)

end

relation elab_vars: (Env, Absyn.VarBnd list, (Absyn.Ident * Types.Ty) list)
          => (Absyn.Ident * Types.Ty) list   =
  rule  list_reverse vars' => vars''
        ----------------
        elab_vars(_, [], vars') => vars''

  rule  elab_var(env, var) => (id,ty) &
        elab_vars(env, vars, (id,ty)::vars') => vars''
        ----------------
        elab_vars(env, var::vars, vars') => vars''
end

relation elab_var:  (Env,Absyn.VarBnd) => (Absyn.Ident,Types.Ty)   =
  rule  elab_ty(env, ty) => ty'
        ----------------
        elab_var(env, Absyn.VARBND(id,ty)) => (id,ty')
end

relation mkvar: (Ident * Types.Ty)  => TCode.Var  =
  rule  Types.ty_cnv ty => ty'
        ----------------
        mkvar((id,ty)) => TCode.VAR(id,ty')
end

relation mkvarbnd:  (Ident * Types.Ty)  =>  (Ident * Bnd) =
  axiom mkvarbnd((id,ty)) => ((id, VARbnd ty))
end

relation elab_formals: (Env, Absyn.VarBnd list) => 
                   (TCode.Var list, (Ident * Bnd) list, Types.Ty list) =

  rule  elab_vars(env, formals, []) => pre_formals &
        map(decay_formal, pre_formals) => pre_formals' &
        map(mkvar, pre_formals') => formals' &
        map(mkvarbnd, pre_formals') => argenv &
        map(extract_ty, pre_formals') => argtys
        ----------------
        elab_formals(env, formals) => (formals', argenv, argtys)
end

relation decay_formal_ty:  Types.Ty => Types.Ty  =

  axiom decay_formal_ty(Types.ARR(_,ty)) => Types.PTR ty
  axiom decay_formal_ty(ty as Types.ARITH _) => ty
  axiom decay_formal_ty(ty as Types.PTR _) => ty
  axiom decay_formal_ty(ty as Types.REC _) => ty

end

relation decay_formal:  (Ident * Types.Ty)  =>  Ident * Types.Ty   =
  rule  decay_formal_ty ty => ty'
        ----------------
        decay_formal((id,ty)) => ((id,ty'))
end

relation extract_ty:  (Ident * Types.Ty)  => Types.Ty  =
  axiom extract_ty((_,y)) => y
end

relation elab_subbnd: (Env, Absyn.SubBnd) => (Env, TCode.Proc)  =

  (* elaborate a function *)
  rule  elab_ty(env0, ty) => ty0 &
        decay_formal_ty ty0 => ty1 &    (* ret ARR ==> ret PTR *)
        Types.ty_cnv ty1 => ty2 &
        elab_formals(env0, formals) => (formals', argenv, argtys) &
        let env1 = (id, FUNCbnd(argtys,ty1))::env0 &
        list_append(argenv, env1) => env2 &
        elab_body(SOME ty1, env2, block) => block'
        ----------------
        elab_subbnd(env0, Absyn.FUNCBND(id,formals,ty,block))
        => (env1, TCode.PROC(id,formals',SOME ty2,block'))

  (* elaborate a procedure *)
  rule  elab_formals(env0, formals) => (formals', argenv, argtys) &
        let env1 = (id, PROCbnd argtys)::env0 &
        list_append(argenv, env1) => env2 &
        elab_body(NONE, env2, block) => block'
        ----------------
        elab_subbnd(env0, Absyn.PROCBND(id,formals,block))
        => (env1, TCode.PROC(id,formals',NONE,block'))
end

relation elab_subbnds: (Env, Absyn.SubBnd list, TCode.Proc list)
          => (Env, TCode.Proc list)   =

  rule  list_reverse subbnds' => subbnds''
        ----------------
        elab_subbnds(env, [], subbnds') => (env,subbnds'')

  rule  elab_subbnd(env, subbnd) => (env',subbnd') &
        elab_subbnds(env', subbnds, subbnd'::subbnds') => (env'',subbnds'')
        ----------------
        elab_subbnds(env, subbnd::subbnds, subbnds') => (env'',subbnds'')
end

relation elab_body: (Types.Ty option, Env, Absyn.Block option)
          => TCode.Block option  =

  axiom elab_body(_, _, NONE) => NONE

  rule  elab_block(fty, env, block) => block'
        ----------------
        elab_body(fty, env, SOME block) => SOME block'
end

relation elab_block: (Types.Ty option, Env, Absyn.Block) => TCode.Block  =

  rule  elab_consts(env0, consts) => env1 &      (* also pushes on env *)
        elab_types(env1, types) => env2 &        (* also pushes on env *)
        elab_vars(env2, vars, []) => pre_vars &  (* only makes pre_vars alst *)
        map(mkvar, pre_vars) => vars' &
        map(mkvarbnd, pre_vars) => varenv &
        list_append(varenv, env2) => env3 &
        elab_subbnds(env3, subbnds, []) => (env4,subbnds') &
        elab_stmt(fty, env4, stmt) => stmt'
        ----------------
        elab_block(fty, env0, Absyn.BLOCK(consts,types,vars,subbnds,stmt))
        => TCode.BLOCK(vars', subbnds', stmt')
end

relation elaborate: Absyn.Prog => TCode.Prog  =
  rule  elab_block(NONE, env_init, block) => block'
        ----------------
        elaborate(Absyn.PROG(id,block)) => TCode.PROG(id,block')
end

