(* flatten.rml *)
module Flatten:
    with "tcode.rml"
    with "fcode.rml"
    relation flatten: TCode.Prog => FCode.Prog
end

datatype Scope  = SCOPE of FCode.Level * FCode.Ident

datatype Bnd    = VAR of FCode.Level * FCode.Record
                | PROC of FCode.Ident

type Env = (FCode.Ident * Bnd) list

val env_init = [("read",        PROC "petrol_read")
,               ("write",       PROC "petrol_write")
,               ("trunc",       PROC "petrol_trunc")
]

 (**?? Question: why copy these utilities here, instead of just calling the
  versions in module Static? Answer: one could perfectly well put them in a
  separate module, e.g. environment or utility. Slightly faster code this way,
  though.*)

relation lookup: (Env, FCode.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 map: ('alpha=>'beta, 'alpha list) => 'beta list =
  axiom map(_, []) => []

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

relation trans_ty: TCode.Ty => FCode.Ty   =

  axiom trans_ty(TCode.CHAR) => FCode.CHAR
  axiom trans_ty(TCode.INT)  => FCode.INT
  axiom trans_ty(TCode.REAL) => FCode.REAL

  rule  trans_ty ty => ty'
        ----------------
        trans_ty(TCode.PTR ty) => FCode.PTR ty'

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

  rule  trans_rec r => r'
        ----------------
        trans_ty(TCode.REC r) => FCode.REC r'

  axiom trans_ty(TCode.UNFOLD stamp) => FCode.UNFOLD stamp
end

and trans_rec: TCode.Record => FCode.Record  =
  rule  map(trans_var, bnds) => bnds'
        ----------------
        trans_rec(TCode.RECORD(stamp,bnds)) => FCode.RECORD(stamp,bnds')
end

and trans_var:  TCode.Var => FCode.Var  =
  rule  trans_ty ty => ty'
        ----------------
        trans_var(TCode.VAR(id,ty)) => FCode.VAR(id,ty')
end

relation trans_tyopt:  TCode.Ty option => FCode.Ty option  =
  axiom trans_tyopt NONE => NONE

  rule  trans_ty ty => ty'
        ----------------
        trans_tyopt(SOME ty) => SOME ty'
end

relation trans_unop: TCode.UnOp => FCode.UnOp   =

  axiom trans_unop(TCode.CtoI) => FCode.CtoI
  axiom trans_unop(TCode.ItoR) => FCode.ItoR
  axiom trans_unop(TCode.RtoI) => FCode.RtoI
  axiom trans_unop(TCode.ItoC) => FCode.ItoC
  axiom trans_unop(TCode.PtoI) => FCode.PtoI

  rule  trans_ty ty => ty'
        ----------------
        trans_unop(TCode.TOPTR ty) => FCode.TOPTR ty'

  rule  trans_ty ty => ty'
        ----------------
        trans_unop(TCode.LOAD ty) => FCode.LOAD ty'

  rule  trans_rec r => r'
        ----------------
        trans_unop(TCode.OFFSET(r,id)) => FCode.OFFSET(r',id)
end

relation trans_binop: TCode.BinOp => FCode.BinOp   =

  axiom trans_binop(TCode.IADD) => FCode.IADD
  axiom trans_binop(TCode.ISUB) => FCode.ISUB
  axiom trans_binop(TCode.IMUL) => FCode.IMUL
  axiom trans_binop(TCode.IDIV) => FCode.IDIV
  axiom trans_binop(TCode.IMOD) => FCode.IMOD
  axiom trans_binop(TCode.IAND) => FCode.IAND
  axiom trans_binop(TCode.IOR) => FCode.IOR
  axiom trans_binop(TCode.ILT) => FCode.ILT
  axiom trans_binop(TCode.ILE) => FCode.ILE
  axiom trans_binop(TCode.IEQ) => FCode.IEQ
  axiom trans_binop(TCode.RADD) => FCode.RADD
  axiom trans_binop(TCode.RSUB) => FCode.RSUB
  axiom trans_binop(TCode.RMUL) => FCode.RMUL
  axiom trans_binop(TCode.RDIV) => FCode.RDIV
  axiom trans_binop(TCode.RLT) => FCode.RLT
  axiom trans_binop(TCode.RLE) => FCode.RLE
  axiom trans_binop(TCode.REQ) => FCode.REQ

  rule  trans_ty ty => ty'
        ----------------
        trans_binop(TCode.PADD ty) => FCode.PADD ty'

  rule  trans_ty ty => ty'
        ----------------
        trans_binop(TCode.PSUB ty) => FCode.PSUB ty'

  rule  trans_ty ty => ty'
        ----------------
        trans_binop(TCode.PDIFF ty) => FCode.PDIFF ty'

  rule  trans_ty ty => ty'
        ----------------
        trans_binop(TCode.PLT ty) => FCode.PLT ty'

  rule  trans_ty ty => ty'
        ----------------
        trans_binop(TCode.PLE ty) => FCode.PLE ty'

  rule  trans_ty ty => ty'
        ----------------
        trans_binop(TCode.PEQ ty) => FCode.PEQ ty'
end

relation trans_procid: (Env, TCode.Ident) => FCode.Ident   =

  rule  lookup(env, id) => PROC id'
        ----------------
        trans_procid(env, id) => id'
end

relation trans_exp: (Env, TCode.Exp) => FCode.Exp   =

  axiom trans_exp(_, TCode.ICON x) => FCode.ICON x
  axiom trans_exp(_, TCode.RCON x) => FCode.RCON x

  (* Lookup a variable id at scope level lev, in activation recordtype r
   * C syntax version:   (struct r* )DISPLAY[lev]->id *)

  rule  lookup(env, id) => VAR(lev,r)
        ----------------
        trans_exp(env, TCode.ADDR id) =>
           FCode.UNARY(FCode.OFFSET(r,id),
                       FCode.UNARY(FCode.TOPTR(FCode.REC r),
                                   FCode.DISPLAY lev))
  rule  trans_unop unop => unop' &
        trans_exp(env, exp) => exp'
        ----------------
        trans_exp(env, TCode.UNARY(unop,exp)) => FCode.UNARY(unop',exp')

  rule  trans_binop binop => binop' &
        trans_exp(env, exp1) => exp1' &
        trans_exp(env, exp2) => exp2'
        ----------------
        trans_exp(env, TCode.BINARY(exp1,binop,exp2)) => 
        FCode.BINARY(exp1',binop',exp2')

 (* Translate the Tcode procedure name to the disambiguated Fcode name *)
  rule  trans_procid(env, id) => id' &
        trans_args(env, args, []) => args'
        ----------------
        trans_exp(env, TCode.FCALL(id,args)) => FCode.FCALL(id',args')
end

relation trans_args: (Env, TCode.Exp list, FCode.Exp list) => FCode.Exp list =
  rule  list_reverse args' => args''
        ----------------
        trans_args(_, [], args') => args''

  rule  trans_exp(env, arg) => arg' &
        trans_args(env, args, arg'::args') => args''
        ----------------
        trans_args(env, arg::args, args') => args''
end

relation trans_return: (Env, (TCode.Ty * TCode.Exp) option) =>
        (FCode.Ty * FCode.Exp) option  =
  axiom trans_return(_, NONE) => NONE

  rule  trans_ty ty => ty' &
        trans_exp(env, exp) => exp'
        ----------------
        trans_return(env, SOME((ty,exp))) => SOME((ty',exp'))
end

relation trans_stmt: (Env, TCode.Stmt) => FCode.Stmt   =

  rule  trans_ty ty => ty' &
        trans_exp(env, lhs) => lhs' &
        trans_exp(env, rhs) => rhs'
        ----------------
        trans_stmt(env, TCode.STORE(ty,lhs,rhs)) => FCode.STORE(ty',lhs',rhs')

  (* Translate procedure identifier *)
  rule  trans_procid(env, id) => id' &
        trans_args(env, args, []) => args'
        ----------------
        trans_stmt(env, TCode.PCALL(id,args)) => FCode.PCALL(id',args')

  rule  trans_return(env, ret) => ret'
        ----------------
        trans_stmt(env, TCode.RETURN ret) => FCode.RETURN ret'

  rule  trans_exp(env, exp) => exp' &
        trans_stmt(env, stmt) => stmt'
        ----------------
        trans_stmt(env, TCode.WHILE(exp,stmt)) => FCode.WHILE(exp',stmt')

  rule  trans_exp(env, exp) => exp' &
        trans_stmt(env, stmt1) => stmt1' &
        trans_stmt(env, stmt2) => stmt2'
        ----------------
       trans_stmt(env,TCode.IF(exp,stmt1,stmt2)) =>
        FCode.IF(exp',stmt1',stmt2')

  rule  trans_stmt(env, stmt1) => stmt1' &
        trans_stmt(env, stmt2) => stmt2'
        ----------------
        trans_stmt(env, TCode.SEQ(stmt1,stmt2)) => FCode.SEQ(stmt1',stmt2')

  axiom trans_stmt(_, TCode.SKIP) => FCode.SKIP
end

relation flatten_proc: (Scope, Env, TCode.Proc, FCode.Proc list) =>
                                                      (Env, FCode.Proc list) =
  (* External procedures without body *)
  rule  map(trans_var, formals) => formals' &
        trans_tyopt tyopt => tyopt'
        ----------------
        flatten_proc(_, env0, TCode.PROC(id,formals,tyopt,NONE), procs0) =>
        ((id,PROC id)::env0, FCode.PROC(id,formals',tyopt',NONE)::procs0)

  (* Module internal procedures with a body *)
  rule  int_add(level0, 1)         => level1 &
        string_append(prefix0, id) => id' & 
        string_append(id', "_")    => prefix1 &  
        map(trans_var, formals)    => formals' & 
        map(trans_var, locals)     => locals' &
        list_append(formals', locals') => vars' & 
        tick  => stamp  & 
        let r = FCode.RECORD(stamp,vars') & 
        let env1 = (id,PROC id')::env0 & 
        env_plus_vars(env1, VAR(level1,r), vars') => env2 & 
        flatten_procs(SCOPE(level1,prefix1), env2, procs, procs0)
          => (env3,procs1) & 
        trans_stmt(env3, stmt) => stmt' & 
        trans_tyopt tyopt => tyopt' 
        ----------------
        flatten_proc(
            SCOPE(level0,prefix0),
            env0,
            TCode.PROC(id,formals,tyopt, SOME(TCode.BLOCK(locals,procs,stmt))),
            procs0)
          => 
          (
           env1,
           FCode.PROC(id', formals', tyopt',
                      SOME(FCode.BLOCK(level1,r,stmt')))::procs1
           )
end

relation env_plus_vars: (Env, Bnd, FCode.Var list) => Env   =

  axiom env_plus_vars(env, _, []) => env

  rule  env_plus_vars((id,bnd)::env, bnd, vars) => env'
        ----------------
        env_plus_vars(env, bnd, FCode.VAR(id,_)::vars) => env'
end

and flatten_procs: (Scope, Env, TCode.Proc list, FCode.Proc list) =>
                                                      (Env, FCode.Proc list) =

  axiom flatten_procs(_, env0, [], procs0) => (env0,procs0)

  rule  flatten_proc(scope, env0, proc, procs0) => (env1,procs1) &
        flatten_procs(scope, env1, procs, procs1) => (env2,procs2)
        ----------------
        flatten_procs(scope, env0, proc::procs, procs0) => (env2,procs2)
end

relation flatten: TCode.Prog => FCode.Prog   =

  rule  flatten_proc(SCOPE(-1,""), env_init,
                     TCode.PROC(progid,[],NONE,SOME(block)),[])  =>  (_,procs')
        ----------------
        flatten(TCode.PROG(progid,block)) => FCode.PROG(procs',progid)
end
