diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index ed2d413..885454a 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -86,7 +86,7 @@ type method_def = m_inputs : var_dec list; m_outputs : var_dec list; m_locals : var_dec list; - m_body : act list; } + m_body : block; } type class_def = { cd_name : class_name; diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml new file mode 100644 index 0000000..8c3debc --- /dev/null +++ b/compiler/obc/obc_mapfold.ml @@ -0,0 +1,207 @@ + (**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* Generic mapred over Obc Ast *) +open Misc +open Global_mapfold +open Obc + +type 'a obc_it_funs = { + 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.lhs -> Obc.lhs * 'a; + lhsdesc: 'a obc_it_funs -> 'a -> Obc.lhs_desc -> Obc.lhs_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; + global_funs:'a Global_mapfold.global_it_funs } + + +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 + | Elhs l -> + let l, acc = lhs_it funs acc l in + Elhs l, acc + | 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 = + let ld, acc = lhsdesc_it funs acc l.l_desc in + { l with l_desc = ld }, acc + + +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 + | 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 + | Acase(x, c_b_list) -> + let aux acc (c,b) = + let b, acc = block_it funs acc b in + (c,b), acc in + let c_b_list, acc = mapfold aux acc c_b_list in + Acase(x, c_b_list), acc + | Afor(x, idx1, idx2, b) -> + let idx1, acc = static_exp_it funs.global_funs acc idx1 in + let idx2, acc = static_exp_it funs.global_funs acc idx2 in + let b, acc = block_it funs acc b in + Afor(x, idx1, idx2, b), acc + +and block_it funs acc b = funs.block funs acc b +and block funs acc b = + mapfold (act_it funs) acc b + + +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_locals, acc = var_decs_it funs acc md.m_locals in + let m_body, acc = block_it funs acc md.m_body in + { md with + m_inputs = m_inputs; m_outputs = m_outputs; + m_locals = m_locals; m_body = m_body } + , acc + + +and class_def_it funs acc cd = funs.class_def funs acc cd +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 = + let td_list, acc = mapfold (type_dec_it funs) acc p.p_types in + let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in + let nd_list, acc = mapfold (class_def_it funs) acc p.p_defs in + { p with p_types = td_list; p_consts = cd_list; p_defs = nd_list }, acc + + +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; + global_funs = Global_mapfold.defaults }