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

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

relation lookup =
  rule	key1 = key0
	----------------
	lookup((key1,bnd)::_, key0) => bnd

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

relation map =
  axiom	map(_, []) => []

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

(********************************************************************************)

relation trans_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

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

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

relation trans_tyopt =
  axiom	trans_tyopt NONE => NONE

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

relation trans_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 =
  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 =
  rule	lookup(env, id) => PROC id'
	----------------
	trans_procid(env, id) => id'
end

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

  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')

  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 =
  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 =
  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 =
  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')

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

relation flatten_proc =
  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)

  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 flatten_procs =
  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 =
  rule	flatten_proc(SCOPE(-1,""),env_init,TCode.PROC(id,[],NONE,SOME block),[]) => (_,procs')
	----------------
	flatten(TCode.PROG(id,block)) => FCode.PROG(procs',id)
end
