2010-07-21 15:53:50 +02:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon *)
|
|
|
|
(* *)
|
|
|
|
(* Author : Marc Pouzet *)
|
|
|
|
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
|
|
|
(* Generic mapred over Obc Ast *)
|
|
|
|
open Misc
|
2010-09-15 09:38:52 +02:00
|
|
|
open Errors
|
2010-07-21 15:53:50 +02:00
|
|
|
open Global_mapfold
|
|
|
|
open Obc
|
|
|
|
|
|
|
|
type 'a obc_it_funs = {
|
2011-04-18 19:20:03 +02:00
|
|
|
exp: 'a obc_it_funs -> 'a -> Obc.exp -> Obc.exp * 'a;
|
|
|
|
edesc: 'a obc_it_funs -> 'a -> Obc.exp_desc -> Obc.exp_desc * 'a;
|
|
|
|
lhs: 'a obc_it_funs -> 'a -> Obc.pattern -> Obc.pattern * 'a;
|
|
|
|
lhsdesc: 'a obc_it_funs -> 'a -> Obc.pat_desc -> Obc.pat_desc * 'a;
|
|
|
|
act: 'a obc_it_funs -> 'a -> Obc.act -> Obc.act * 'a;
|
|
|
|
block: 'a obc_it_funs -> 'a -> Obc.block -> Obc.block * 'a;
|
|
|
|
var_dec: 'a obc_it_funs -> 'a -> Obc.var_dec -> Obc.var_dec * 'a;
|
|
|
|
var_decs: 'a obc_it_funs -> 'a -> Obc.var_dec list -> Obc.var_dec list * 'a;
|
|
|
|
obj_dec: 'a obc_it_funs -> 'a -> Obc.obj_dec -> Obc.obj_dec * 'a;
|
|
|
|
obj_decs: 'a obc_it_funs -> 'a -> Obc.obj_dec list -> Obc.obj_dec list * 'a;
|
|
|
|
method_def: 'a obc_it_funs -> 'a -> Obc.method_def -> Obc.method_def * 'a;
|
|
|
|
class_def: 'a obc_it_funs -> 'a -> Obc.class_def -> Obc.class_def * 'a;
|
|
|
|
const_dec: 'a obc_it_funs -> 'a -> Obc.const_dec -> Obc.const_dec * 'a;
|
|
|
|
type_dec: 'a obc_it_funs -> 'a -> Obc.type_dec -> Obc.type_dec * 'a;
|
|
|
|
tdesc: 'a obc_it_funs -> 'a -> Obc.tdesc -> Obc.tdesc * 'a;
|
|
|
|
program: 'a obc_it_funs -> 'a -> Obc.program -> Obc.program * 'a;
|
2011-04-19 18:45:56 +02:00
|
|
|
program_desc: 'a obc_it_funs -> 'a -> Obc.program_desc -> Obc.program_desc * 'a;
|
2011-04-18 19:20:03 +02:00
|
|
|
global_funs: 'a Global_mapfold.global_it_funs }
|
2010-07-21 15:53:50 +02:00
|
|
|
|
|
|
|
|
|
|
|
let rec exp_it funs acc e = funs.exp funs acc e
|
|
|
|
and exp funs acc e =
|
|
|
|
let ed, acc = edesc_it funs acc e.e_desc in
|
|
|
|
{ e with e_desc = ed }, acc
|
|
|
|
|
|
|
|
|
|
|
|
and edesc_it funs acc ed =
|
|
|
|
try funs.edesc funs acc ed
|
|
|
|
with Fallback -> edesc funs acc ed
|
|
|
|
and edesc funs acc ed = match ed with
|
2011-01-24 16:07:26 +01:00
|
|
|
| Epattern l ->
|
2010-07-21 15:53:50 +02:00
|
|
|
let l, acc = lhs_it funs acc l in
|
2011-01-24 16:07:26 +01:00
|
|
|
Epattern l, acc
|
2010-07-21 15:53:50 +02:00
|
|
|
| Econst se ->
|
|
|
|
let se, acc = static_exp_it funs.global_funs acc se in
|
|
|
|
Econst se, acc
|
|
|
|
| Eop (op, args) ->
|
|
|
|
let args, acc = mapfold (exp_it funs) acc args in
|
|
|
|
Eop (op, args), acc
|
|
|
|
| Estruct(tyn, f_e_list) ->
|
|
|
|
let aux acc (f,e) =
|
|
|
|
let e, acc = exp_it funs acc e in
|
|
|
|
(f,e), acc in
|
|
|
|
let f_e_list, acc = mapfold aux acc f_e_list in
|
|
|
|
Estruct(tyn, f_e_list), acc
|
|
|
|
| Earray args ->
|
|
|
|
let args, acc = mapfold (exp_it funs) acc args in
|
|
|
|
Earray args, acc
|
|
|
|
|
|
|
|
|
|
|
|
and lhs_it funs acc l = funs.lhs funs acc l
|
|
|
|
and lhs funs acc l =
|
2010-11-05 15:36:11 +01:00
|
|
|
let ld, acc = lhsdesc_it funs acc l.pat_desc in
|
|
|
|
{ l with pat_desc = ld }, acc
|
2010-07-21 15:53:50 +02:00
|
|
|
|
|
|
|
|
|
|
|
and lhsdesc_it funs acc ld =
|
|
|
|
try funs.lhsdesc funs acc ld
|
|
|
|
with Fallback -> lhsdesc funs acc ld
|
|
|
|
and lhsdesc funs acc ld = match ld with
|
|
|
|
| Lvar x -> Lvar x, acc
|
|
|
|
| Lmem x -> Lmem x, acc
|
|
|
|
| Lfield(lhs, f) ->
|
|
|
|
let lhs, acc = lhs_it funs acc lhs in
|
|
|
|
Lfield(lhs, f), acc
|
|
|
|
| Larray(lhs, e) ->
|
|
|
|
let lhs, acc = lhs_it funs acc lhs in
|
|
|
|
let e, acc = exp_it funs acc e in
|
|
|
|
Larray(lhs, e), acc
|
|
|
|
|
|
|
|
|
|
|
|
and act_it funs acc a =
|
|
|
|
try funs.act funs acc a
|
|
|
|
with Fallback -> act funs acc a
|
|
|
|
and act funs acc a = match a with
|
|
|
|
| Aassgn(lhs, e) ->
|
|
|
|
let lhs, acc = lhs_it funs acc lhs in
|
|
|
|
let e, acc = exp_it funs acc e in
|
|
|
|
Aassgn(lhs, e), acc
|
2011-04-28 15:20:21 +02:00
|
|
|
| Aop(op_name, args) ->
|
|
|
|
let args, acc = mapfold (exp_it funs) acc args in
|
|
|
|
Aop(op_name, args), acc
|
2010-07-21 15:53:50 +02:00
|
|
|
| Acall(lhs_list, obj, n, args) ->
|
|
|
|
let lhs_list, acc = mapfold (lhs_it funs) acc lhs_list in
|
|
|
|
let args, acc = mapfold (exp_it funs) acc args in
|
|
|
|
Acall(lhs_list, obj, n, args), acc
|
2011-05-16 17:30:48 +02:00
|
|
|
| Acase(e, c_b_list) ->
|
2010-07-21 15:53:50 +02:00
|
|
|
let aux acc (c,b) =
|
|
|
|
let b, acc = block_it funs acc b in
|
|
|
|
(c,b), acc in
|
2011-05-16 17:30:48 +02:00
|
|
|
let e, acc = exp_it funs acc e in
|
2010-07-21 15:53:50 +02:00
|
|
|
let c_b_list, acc = mapfold aux acc c_b_list in
|
2011-05-16 17:30:48 +02:00
|
|
|
Acase(e, c_b_list), acc
|
2010-07-21 15:53:50 +02:00
|
|
|
| Afor(x, idx1, idx2, b) ->
|
2011-04-18 15:38:42 +02:00
|
|
|
let idx1, acc = exp_it funs acc idx1 in
|
|
|
|
let idx2, acc = exp_it funs acc idx2 in
|
2010-07-21 15:53:50 +02:00
|
|
|
let b, acc = block_it funs acc b in
|
|
|
|
Afor(x, idx1, idx2, b), acc
|
2011-03-08 13:41:28 +01:00
|
|
|
| Ablock b ->
|
|
|
|
let b, acc = block_it funs acc b in
|
|
|
|
Ablock b, acc
|
2010-07-21 15:53:50 +02:00
|
|
|
|
|
|
|
and block_it funs acc b = funs.block funs acc b
|
|
|
|
and block funs acc b =
|
2010-07-22 09:36:22 +02:00
|
|
|
let b_locals, acc = var_decs_it funs acc b.b_locals in
|
|
|
|
let b_body, acc = mapfold (act_it funs) acc b.b_body in
|
|
|
|
{ b with b_locals = b_locals; b_body = b_body }, acc
|
2010-07-21 15:53:50 +02:00
|
|
|
|
|
|
|
and var_dec_it funs acc vd = funs.var_dec funs acc vd
|
|
|
|
and var_dec funs acc vd =
|
|
|
|
let v_type, acc = ty_it funs.global_funs acc vd.v_type in
|
|
|
|
{ vd with v_type = v_type }, acc
|
|
|
|
|
|
|
|
and var_decs_it funs acc vds = funs.var_decs funs acc vds
|
|
|
|
and var_decs funs acc vds = mapfold (var_dec_it funs) acc vds
|
|
|
|
|
|
|
|
|
|
|
|
and obj_dec_it funs acc od = funs.obj_dec funs acc od
|
|
|
|
and obj_dec funs acc od =
|
|
|
|
let o_size, acc = optional_wacc
|
|
|
|
(static_exp_it funs.global_funs) acc od.o_size in
|
|
|
|
{ od with o_size = o_size }, acc
|
|
|
|
|
|
|
|
and obj_decs_it funs acc ods = funs.obj_decs funs acc ods
|
|
|
|
and obj_decs funs acc ods = mapfold (obj_dec_it funs) acc ods
|
|
|
|
|
|
|
|
|
|
|
|
and method_def_it funs acc md = funs.method_def funs acc md
|
|
|
|
and method_def funs acc md =
|
|
|
|
let m_inputs, acc = var_decs_it funs acc md.m_inputs in
|
|
|
|
let m_outputs, acc = var_decs_it funs acc md.m_outputs in
|
|
|
|
let m_body, acc = block_it funs acc md.m_body in
|
|
|
|
{ md with
|
2010-07-22 09:36:22 +02:00
|
|
|
m_inputs = m_inputs; m_outputs = m_outputs; m_body = m_body }
|
2010-07-21 15:53:50 +02:00
|
|
|
, acc
|
|
|
|
|
|
|
|
|
2011-03-21 14:30:19 +01:00
|
|
|
and class_def_it funs acc cd =
|
|
|
|
Idents.enter_node cd.cd_name;
|
|
|
|
funs.class_def funs acc cd
|
2010-07-21 15:53:50 +02:00
|
|
|
and class_def funs acc cd =
|
|
|
|
let cd_mems, acc = var_decs_it funs acc cd.cd_mems in
|
|
|
|
let cd_objs, acc = obj_decs_it funs acc cd.cd_objs in
|
|
|
|
let cd_params, acc = mapfold (param_it funs.global_funs) acc cd.cd_params in
|
|
|
|
let cd_methods, acc = mapfold (method_def_it funs) acc cd.cd_methods in
|
|
|
|
{ cd with
|
|
|
|
cd_mems = cd_mems; cd_objs = cd_objs;
|
|
|
|
cd_params = cd_params; cd_methods = cd_methods }
|
|
|
|
, acc
|
|
|
|
|
|
|
|
|
|
|
|
and const_dec_it funs acc c = funs.const_dec funs acc c
|
|
|
|
and const_dec funs acc c =
|
|
|
|
let ty, acc = ty_it funs.global_funs acc c.c_type in
|
|
|
|
let se, acc = static_exp_it funs.global_funs acc c.c_value in
|
|
|
|
{ c with c_type = ty; c_value = se }, acc
|
|
|
|
|
|
|
|
|
|
|
|
and type_dec_it funs acc t = funs.type_dec funs acc t
|
|
|
|
and type_dec funs acc t =
|
|
|
|
let tdesc, acc = tdesc_it funs acc t.t_desc in
|
|
|
|
{ t with t_desc = tdesc }, acc
|
|
|
|
|
|
|
|
|
|
|
|
and tdesc_it funs acc td =
|
|
|
|
try funs.tdesc funs acc td
|
|
|
|
with Fallback -> tdesc funs acc td
|
|
|
|
and tdesc funs acc td = match td with
|
|
|
|
| Type_struct s ->
|
|
|
|
let s, acc = structure_it funs.global_funs acc s in
|
|
|
|
Type_struct s, acc
|
|
|
|
| _ -> td, acc
|
|
|
|
|
|
|
|
|
|
|
|
and program_it funs acc p = funs.program funs acc p
|
|
|
|
and program funs acc p =
|
2011-04-18 19:20:03 +02:00
|
|
|
let p_desc, acc = mapfold (program_desc_it funs) acc p.p_desc in
|
|
|
|
{ p with p_desc = p_desc }, acc
|
2010-07-21 15:53:50 +02:00
|
|
|
|
2011-04-18 19:20:03 +02:00
|
|
|
and program_desc_it funs acc pd =
|
|
|
|
try funs.program_desc funs acc pd
|
|
|
|
with Fallback -> program_desc funs acc pd
|
|
|
|
and program_desc funs acc pd = match pd with
|
2011-04-19 18:45:56 +02:00
|
|
|
| Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc
|
|
|
|
| Ptype td -> let td, acc = type_dec_it funs acc td in Ptype td, acc
|
|
|
|
| Pclass n -> let n, acc = class_def_it funs acc n in Pclass n, acc
|
2010-07-21 15:53:50 +02:00
|
|
|
|
|
|
|
let defaults = {
|
|
|
|
lhs = lhs;
|
|
|
|
lhsdesc = lhsdesc;
|
|
|
|
exp = exp;
|
|
|
|
edesc = edesc;
|
|
|
|
act = act;
|
|
|
|
block = block;
|
|
|
|
var_dec = var_dec;
|
|
|
|
var_decs = var_decs;
|
|
|
|
obj_dec = obj_dec;
|
|
|
|
obj_decs = obj_decs;
|
|
|
|
method_def = method_def;
|
|
|
|
class_def = class_def;
|
|
|
|
const_dec = const_dec;
|
|
|
|
type_dec = type_dec;
|
|
|
|
tdesc = tdesc;
|
|
|
|
program = program;
|
2011-04-19 18:45:56 +02:00
|
|
|
program_desc = program_desc;
|
2010-07-21 15:53:50 +02:00
|
|
|
global_funs = Global_mapfold.defaults }
|