From 8da5ce46484bd5d9779a61fef72cabea4fef511e Mon Sep 17 00:00:00 2001 From: Leonard Gerard Date: Mon, 18 Apr 2011 19:20:03 +0200 Subject: [PATCH] no order in declarations --- compiler/heptagon/analysis/causality.ml | 4 +- compiler/heptagon/analysis/initialization.ml | 4 +- compiler/heptagon/analysis/typing.ml | 12 +- compiler/heptagon/hept_mapfold.ml | 15 ++- compiler/heptagon/hept_printer.ml | 18 +-- compiler/heptagon/heptagon.ml | 10 +- compiler/heptagon/parsing/hept_parser.mly | 43 ++----- compiler/heptagon/parsing/hept_parsetree.ml | 14 ++- .../parsing/hept_parsetree_mapfold.ml | 109 +++++++----------- compiler/heptagon/parsing/hept_scoping.ml | 14 ++- compiler/heptagon/transformations/automata.ml | 4 +- compiler/heptagon/transformations/itfusion.ml | 4 +- compiler/main/mls2obc.ml | 45 ++++---- compiler/minils/minils.ml | 9 +- compiler/minils/mls_mapfold.ml | 17 ++- compiler/minils/mls_printer.ml | 13 ++- compiler/minils/transformations/callgraph.ml | 18 ++- compiler/obc/obc.ml | 11 +- compiler/obc/obc_mapfold.ml | 51 ++++---- 19 files changed, 212 insertions(+), 203 deletions(-) diff --git a/compiler/heptagon/analysis/causality.ml b/compiler/heptagon/analysis/causality.ml index 975406a..5a44c59 100644 --- a/compiler/heptagon/analysis/causality.ml +++ b/compiler/heptagon/analysis/causality.ml @@ -217,7 +217,7 @@ let typing_node { n_contract = contract; let _ = typing_contract loc contract in ignore (typing_block b) -let program ({ p_nodes = p_node_list } as p) = - List.iter typing_node p_node_list; +let program ({ p_desc = pd } as p) = + List.iter (function Pnode n -> typing_node n | _ -> ()) pd; p diff --git a/compiler/heptagon/analysis/initialization.ml b/compiler/heptagon/analysis/initialization.ml index 9232a1f..d122e43 100644 --- a/compiler/heptagon/analysis/initialization.ml +++ b/compiler/heptagon/analysis/initialization.ml @@ -387,8 +387,8 @@ let typing_node { n_input = i_list; n_output = o_list; let h = typing_contract h contract in ignore (typing_block h b) -let program ({ p_nodes = p_node_list } as p) = - List.iter typing_node p_node_list; +let program ({ p_desc = pd } as p) = + List.iter (function Pnode n -> typing_node n | _ -> ()) pd; p diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 6ae3449..199891b 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -1096,8 +1096,10 @@ let typing_const_dec cd = let se = expect_static_exp QualEnv.empty ty cd.c_value in { cd with c_value = se; c_type = ty } -let program - ({ p_nodes = p_node_list; p_consts = p_consts_list } as p) = - let typed_cd_list = List.map typing_const_dec p_consts_list in - let typed_node_list = List.map node p_node_list in - { p with p_nodes = typed_node_list; p_consts = typed_cd_list } +let program p = + let program_desc pd = match pd with + | Pnode n -> Pnode (node n) + | Pconst c -> Pconst (typing_const_dec c) + | _ -> pd + in + { p with p_desc = List.map program_desc p.p_desc } diff --git a/compiler/heptagon/hept_mapfold.ml b/compiler/heptagon/hept_mapfold.ml index be29712..298e552 100644 --- a/compiler/heptagon/hept_mapfold.ml +++ b/compiler/heptagon/hept_mapfold.ml @@ -72,6 +72,7 @@ type 'a hept_it_funs = { node_dec : 'a hept_it_funs -> 'a -> node_dec -> node_dec * 'a; const_dec : 'a hept_it_funs -> 'a -> const_dec -> const_dec * 'a; program : 'a hept_it_funs -> 'a -> program -> program * 'a; + program_desc : 'a hept_it_funs -> 'a -> program_desc -> program_desc * 'a; global_funs : 'a Global_mapfold.global_it_funs } @@ -276,10 +277,16 @@ and const_dec funs acc c = and program_it funs acc p = funs.program funs acc p and program funs acc p = - let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in - let nd_list, acc = mapfold (node_dec_it funs) acc p.p_nodes in - { p with p_consts = cd_list; p_nodes = nd_list }, acc + let p_desc, acc = mapfold (program_desc_it funs) acc p.p_desc in + { p with p_desc = p_desc }, acc +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 + | Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc + | Ptype td -> (*let td, acc = Global_mapfold.ty_it funs.global_funs acc td in Ptype td, acc*) pd, acc + | Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc let defaults = { app = app; @@ -300,6 +307,7 @@ let defaults = { node_dec = node_dec; const_dec = const_dec; program = program; + program_desc = program_desc; global_funs = Global_mapfold.defaults } @@ -323,6 +331,7 @@ let defaults_stop = { node_dec = stop; const_dec = stop; program = stop; + program_desc = stop; global_funs = Global_mapfold.defaults_stop } diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index e6795a1..4cf1bf0 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -57,12 +57,11 @@ let print_local_vars s ff l = match l with let print_const_dec ff c = if !Compiler_options.full_type_info then - fprintf ff "const %a : %a = %a" + fprintf ff "const %a : %a = %a@." print_qualname c.c_name print_type c.c_type print_static_exp c.c_value else - fprintf ff "const %a = %a" - print_qualname c.c_name print_static_exp c.c_value; - fprintf ff "@." + fprintf ff "const %a = %a@." + print_qualname c.c_name print_static_exp c.c_value let rec print_params ff l = @@ -290,12 +289,15 @@ let print_node ff (print_local_vars "") nb.b_local print_eq_list nb.b_equs +let print_pdesc ff pd = match pd with + | Pnode n -> print_node ff n + | Pconst c -> print_const_dec ff c + | Ptype t -> print_type_def ff t + let print_open_module ff name = fprintf ff "open %s@." (modul_to_string name) -let print oc { p_opened = po; p_types = pt; p_nodes = pn; p_consts = pc } = +let print oc { p_opened = po; p_desc = pd; } = let ff = Format.formatter_of_out_channel oc in List.iter (print_open_module ff) po; - List.iter (print_const_dec ff) pc; - List.iter (print_type_def ff) pt; - List.iter (print_node ff) pn; + List.iter (print_pdesc ff) pd; fprintf ff "@?" diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index ea83fef..5816079 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -161,9 +161,13 @@ type const_dec = { type program = { p_modname : modul; p_opened : modul list; - p_types : type_dec list; - p_nodes : node_dec list; - p_consts : const_dec list } + p_desc : program_desc list } + +and program_desc = + | Ptype of type_dec + | Pnode of node_dec + | Pconst of const_dec + type signature = { sig_name : qualname; diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index f816dbc..0f410fc 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -112,38 +112,20 @@ optsnlist(S,x) : |/* empty */ { None } | P v=x { Some(v) } -program: - | pragma_headers open_modules const_decs type_decs node_decs EOF - {{ p_modname = ""; - p_pragmas = $1; - p_opened = List.rev $2; - p_types = $4; - p_nodes = $5; - p_consts = $3; }} +program: o=list(opens) p=list(program_desc) { {p_modname = ""; p_opened = o; p_desc = p} } + +program_desc: + | p=PRAGMA { Ppragma p } + | c=const_dec { Pconst c } + | t=type_dec { Ptype t } + | n=node_dec { Pnode n } ; -pragma_headers: - | /* empty */ { [] } - | PRAGMA pragma_headers { $1 :: $2 } - -open_modules: - | /* empty */ { [] } - | open_modules OPEN modul { $3 :: $1 } -; - -const_decs: - | /* empty */ { [] } - | const_dec const_decs { $1 :: $2 } -; +opens: OPEN m=modul { m } const_dec: - | CONST IDENT COLON ty_ident EQUAL exp - { mk_const_dec $2 $4 $6 (Loc($startpos,$endpos)) } -; - -type_decs: - | /* empty */ { [] } - | type_dec type_decs { $1 :: $2 } + | CONST x=IDENT COLON t=ty_ident EQUAL e=exp + { mk_const_dec x t e (Loc($startpos,$endpos)) } ; type_dec: @@ -177,11 +159,6 @@ label_ty: IDENT COLON ty_ident { $1, $3 } ; -node_decs: - | /* empty */ {[]} - | node_dec node_decs {$1 :: $2} -; - node_dec: | node_or_fun ident node_params LPAREN in_params RPAREN RETURNS LPAREN out_params RPAREN diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index 95c9259..7b48c9e 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -180,11 +180,15 @@ type const_dec = type program = { p_modname : dec_name; - p_pragmas : (var_name * string) list; - p_opened : module_name list; - p_types : type_dec list; - p_nodes : node_dec list; - p_consts : const_dec list; } + p_opened : module_name list; + p_desc : program_desc list } + +and program_desc = + | Ppragma of (var_name * string) + | Ptype of type_dec + | Pconst of const_dec + | Pnode of node_dec + type arg = { a_type : ty; diff --git a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml index afe872f..c094b68 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -15,65 +15,34 @@ open Hept_parsetree type 'a hept_it_funs = { ty : 'a hept_it_funs -> 'a -> Hept_parsetree.ty -> Hept_parsetree.ty * 'a; - static_exp : - 'a hept_it_funs -> 'a -> Hept_parsetree.static_exp -> static_exp * 'a; - static_exp_desc : - 'a hept_it_funs -> 'a -> Hept_parsetree.static_exp_desc -> - Hept_parsetree.static_exp_desc * 'a; - app: - 'a hept_it_funs -> 'a -> Hept_parsetree.app -> Hept_parsetree.app * 'a; - block: - 'a hept_it_funs -> 'a -> Hept_parsetree.block -> Hept_parsetree.block * 'a; - edesc: - 'a hept_it_funs -> 'a -> Hept_parsetree.edesc -> Hept_parsetree.edesc * 'a; - eq: - 'a hept_it_funs -> 'a -> Hept_parsetree.eq -> Hept_parsetree.eq * 'a; - eqdesc: - 'a hept_it_funs -> 'a -> Hept_parsetree.eqdesc -> - Hept_parsetree.eqdesc * 'a; - escape_unless : - 'a hept_it_funs -> 'a -> Hept_parsetree.escape -> - Hept_parsetree.escape * 'a; - escape_until: - 'a hept_it_funs -> 'a -> Hept_parsetree.escape -> - Hept_parsetree.escape * 'a; - exp: - 'a hept_it_funs -> 'a -> Hept_parsetree.exp -> Hept_parsetree.exp * 'a; - pat: - 'a hept_it_funs -> 'a -> pat -> Hept_parsetree.pat * 'a; - present_handler: - 'a hept_it_funs -> 'a -> Hept_parsetree.present_handler - -> Hept_parsetree.present_handler * 'a; - state_handler: - 'a hept_it_funs -> 'a -> Hept_parsetree.state_handler - -> Hept_parsetree.state_handler * 'a; - switch_handler: - 'a hept_it_funs -> 'a -> Hept_parsetree.switch_handler - -> Hept_parsetree.switch_handler * 'a; - var_dec: - 'a hept_it_funs -> 'a -> Hept_parsetree.var_dec -> - Hept_parsetree.var_dec * 'a; - last: - 'a hept_it_funs -> 'a -> Hept_parsetree.last -> Hept_parsetree.last * 'a; - contract: - 'a hept_it_funs -> 'a -> Hept_parsetree.contract -> - Hept_parsetree.contract * 'a; - node_dec: - 'a hept_it_funs -> 'a -> Hept_parsetree.node_dec -> - Hept_parsetree.node_dec * 'a; - const_dec: - 'a hept_it_funs -> 'a -> Hept_parsetree.const_dec -> - Hept_parsetree.const_dec * 'a; - type_dec: - 'a hept_it_funs -> 'a -> Hept_parsetree.type_dec -> - Hept_parsetree.type_dec * 'a; - type_desc: - 'a hept_it_funs -> 'a -> Hept_parsetree.type_desc -> - Hept_parsetree.type_desc * 'a; - program: - 'a hept_it_funs -> 'a -> Hept_parsetree.program -> - Hept_parsetree.program * 'a; } - + static_exp : 'a hept_it_funs -> 'a -> Hept_parsetree.static_exp -> static_exp * 'a; + static_exp_desc : 'a hept_it_funs -> 'a -> Hept_parsetree.static_exp_desc + -> Hept_parsetree.static_exp_desc * 'a; + app: 'a hept_it_funs -> 'a -> Hept_parsetree.app -> Hept_parsetree.app * 'a; + block: 'a hept_it_funs -> 'a -> Hept_parsetree.block -> Hept_parsetree.block * 'a; + edesc: 'a hept_it_funs -> 'a -> Hept_parsetree.edesc -> Hept_parsetree.edesc * 'a; + eq: 'a hept_it_funs -> 'a -> Hept_parsetree.eq -> Hept_parsetree.eq * 'a; + eqdesc: 'a hept_it_funs -> 'a -> Hept_parsetree.eqdesc -> Hept_parsetree.eqdesc * 'a; + escape_unless : 'a hept_it_funs -> 'a -> Hept_parsetree.escape -> Hept_parsetree.escape * 'a; + escape_until: 'a hept_it_funs -> 'a -> Hept_parsetree.escape -> Hept_parsetree.escape * 'a; + exp: 'a hept_it_funs -> 'a -> Hept_parsetree.exp -> Hept_parsetree.exp * 'a; + pat: 'a hept_it_funs -> 'a -> pat -> Hept_parsetree.pat * 'a; + present_handler: 'a hept_it_funs -> 'a -> Hept_parsetree.present_handler + -> Hept_parsetree.present_handler * 'a; + state_handler: 'a hept_it_funs -> 'a -> Hept_parsetree.state_handler + -> Hept_parsetree.state_handler * 'a; + switch_handler: 'a hept_it_funs -> 'a -> Hept_parsetree.switch_handler + -> Hept_parsetree.switch_handler * 'a; + var_dec: 'a hept_it_funs -> 'a -> Hept_parsetree.var_dec -> Hept_parsetree.var_dec * 'a; + last: 'a hept_it_funs -> 'a -> Hept_parsetree.last -> Hept_parsetree.last * 'a; + contract: 'a hept_it_funs -> 'a -> Hept_parsetree.contract -> Hept_parsetree.contract * 'a; + node_dec: 'a hept_it_funs -> 'a -> Hept_parsetree.node_dec -> Hept_parsetree.node_dec * 'a; + const_dec: 'a hept_it_funs -> 'a -> Hept_parsetree.const_dec -> Hept_parsetree.const_dec * 'a; + type_dec: 'a hept_it_funs -> 'a -> Hept_parsetree.type_dec -> Hept_parsetree.type_dec * 'a; + type_desc: 'a hept_it_funs -> 'a -> Hept_parsetree.type_desc -> Hept_parsetree.type_desc * 'a; + program: 'a hept_it_funs -> 'a -> Hept_parsetree.program -> Hept_parsetree.program * 'a; + program_desc: 'a hept_it_funs -> 'a -> Hept_parsetree.program_desc + -> Hept_parsetree.program_desc * 'a; } let rec static_exp_it funs acc se = funs.static_exp funs acc se and static_exp funs acc se = @@ -329,11 +298,17 @@ and type_desc funs acc td = match td with and program_it funs acc p = funs.program funs acc p and program funs acc p = - let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in - let td_list, acc = mapfold (type_dec_it funs) acc p.p_types in - let nd_list, acc = mapfold (node_dec_it funs) acc p.p_nodes in - { p with p_consts = cd_list; p_nodes = nd_list; p_types = td_list }, acc - + let p_desc, acc = mapfold (program_desc funs) acc p.p_desc in + { p with p_desc = p_desc }, acc + +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 + | Pconst c -> let c, acc = const_dec_it funs acc c in Pconst c, acc + | Ptype t -> let t, acc = type_dec_it funs acc t in Ptype t, acc + | Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc + | Ppragma _ -> pd, acc let defaults = { ty = ty; @@ -358,7 +333,8 @@ let defaults = { const_dec = const_dec; type_dec = type_dec; type_desc = type_desc; - program = program } + program = program; + program_desc = program_desc } @@ -385,5 +361,6 @@ let defaults_stop = { const_dec = stop; type_dec = stop; type_desc = stop; - program = stop } + program = stop; + program_desc = stop } diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index bda7df3..eb9b813 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -454,15 +454,17 @@ let translate_const_dec cd = Heptagon.c_loc = cd.c_loc; } let translate_program p = + let translate_program_desc pd = match pd with + | Ppragma _ -> Misc.unsupported "pragma in scoping" 1 + | Pconst c -> Heptagon.Pconst (translate_const_dec c) + | Ptype t -> Heptagon.Ptype (translate_typedec t) + | Pnode n -> Heptagon.Pnode (translate_node n) + in List.iter open_module p.p_opened; - let consts = List.map translate_const_dec p.p_consts in - let types = List.map translate_typedec p.p_types in - let nodes = List.map translate_node p.p_nodes in + let desc = List.map translate_program_desc p.p_desc in { Heptagon.p_modname = Names.modul_of_string p.p_modname; Heptagon.p_opened = p.p_opened; - Heptagon.p_types = types; - Heptagon.p_nodes = nodes; - Heptagon.p_consts = consts; } + Heptagon.p_desc = desc; } let translate_signature s = let translate_arg a = diff --git a/compiler/heptagon/transformations/automata.ml b/compiler/heptagon/transformations/automata.ml index 28f0412..67c0502 100644 --- a/compiler/heptagon/transformations/automata.ml +++ b/compiler/heptagon/transformations/automata.ml @@ -63,7 +63,7 @@ let intro_type type_name state_env = Modules.add_type type_name (Signature.Tenum state_constrs); (* Add the new type to the types to add to the Ast *) state_type_dec_list := - (mk_type_dec type_name (Type_enum state_constrs)) :: !state_type_dec_list + Ptype (mk_type_dec type_name (Type_enum state_constrs)) :: !state_type_dec_list (** Allows to classify an automaton : Moore automatons doesn't have strong transitions, @@ -182,4 +182,4 @@ let program p = let funs = { Hept_mapfold.defaults with eq = eq; block = block } in let p, _ = Hept_mapfold.program_it funs ([],[]) p in - { p with p_types = !state_type_dec_list @ p.p_types } + { p with p_desc = !state_type_dec_list @ p.p_desc } diff --git a/compiler/heptagon/transformations/itfusion.ml b/compiler/heptagon/transformations/itfusion.ml index f7c7caf..fa48fb2 100644 --- a/compiler/heptagon/transformations/itfusion.ml +++ b/compiler/heptagon/transformations/itfusion.ml @@ -141,5 +141,5 @@ let edesc funs acc ed = let program p = let funs = { Hept_mapfold.defaults with edesc = edesc } in let p, _ = Hept_mapfold.program_it funs false p in - let added_nodes = QualEnv.fold (fun _ nd l -> nd::l) !anon_nodes [] in - { p with p_nodes = added_nodes @ p.p_nodes } + let pd = QualEnv.fold (fun _ nd l -> Pnode nd :: l) !anon_nodes p.p_desc in + { p with p_desc = pd } diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index e46051b..fa8249e 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -23,21 +23,18 @@ open Initial let build_anon, find_anon = let anon_nodes = ref QualEnv.empty in - let build_anon nodes = - let build env nd = - if Itfusion.is_anon_node nd.Minils.n_name then - QualEnv.add nd.Minils.n_name nd env - else - env + let build env nd = match nd with + | Minils.Pnode nd -> + if Itfusion.is_anon_node nd.Minils.n_name + then QualEnv.add nd.Minils.n_name nd env + else env + | _ -> env in - anon_nodes := List.fold_left build QualEnv.empty nodes + anon_nodes := List.fold_left build QualEnv.empty nodes in - - let find_anon qn = - QualEnv.find qn !anon_nodes - in - build_anon, find_anon + let find_anon qn = QualEnv.find qn !anon_nodes in + build_anon, find_anon let var_from_name map x = begin try @@ -642,17 +639,19 @@ let translate_const_def { Minils.c_name = name; Minils.c_value = se; c_type = ty; c_loc = loc } -let program { Minils.p_modname = p_modname; Minils.p_opened = p_module_list; - Minils.p_types = p_type_list; - Minils.p_nodes = p_node_list; Minils.p_consts = p_const_list } = - build_anon p_node_list; - (* dont't translate anonymous nodes, they will be inlined *) - let p_nodes_list = List.filter - (fun nd -> not (Itfusion.is_anon_node nd.Minils.n_name)) p_node_list in +let program { Minils.p_modname = p_modname; Minils.p_opened = p_o; Minils.p_desc = pd; } = + build_anon pd; + + let program_desc pd acc = match pd with + | Minils.Pnode n when not (Itfusion.is_anon_node n.Minils.n_name) -> + Pclass (translate_node n) :: acc + (* dont't translate anonymous nodes, they will be inlined TODO ?? inline obc code hein ?*) + | Minils.Pnode n -> acc + | Minils.Ptype t -> Ptype (translate_ty_def t) :: acc + | Minils.Pconst c -> Pconst (translate_const_def c) :: acc + in + let p_desc = List.fold_right program_desc [] pd in { p_modname = p_modname; p_opened = p_module_list; - p_types = List.map translate_ty_def p_type_list; - p_consts = List.map translate_const_def p_const_list; - p_classes = List.map translate_node p_nodes_list; } - + p_desc = p_desc } diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index a831c3a..a1c9be9 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -138,9 +138,12 @@ type program = { p_modname : modul; p_format_version : string; p_opened : modul list; - p_types : type_dec list; - p_nodes : node_dec list; - p_consts : const_dec list } + p_desc : program_desc list } + +and program_desc = + | Pnode of node_dec + | Pconst of const_dec + | Ptype of type_dec (*Helper functions to build the AST*) diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index d3719df..4fff883 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -33,6 +33,7 @@ type 'a mls_it_funs = { type_dec: 'a mls_it_funs -> 'a -> Minils.type_dec -> Minils.type_dec * 'a; tdesc: 'a mls_it_funs -> 'a -> Minils.tdesc -> Minils.tdesc * 'a; program: 'a mls_it_funs -> 'a -> Minils.program -> Minils.program * 'a; + program_desc: 'a mls_it_funs -> 'a -> Minils.program_desc -> Minils.program_desc * 'a; global_funs: 'a Global_mapfold.global_it_funs } @@ -189,10 +190,17 @@ and tdesc funs acc td = match td with and program_it funs acc p = funs.program funs acc p and program funs acc p = - let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in - let td_list, acc = mapfold (type_dec_it funs) acc p.p_types in - let nd_list, acc = mapfold (node_dec_it funs) acc p.p_nodes in - { p with p_types = td_list; p_consts = cd_list; p_nodes = nd_list }, acc + let p_desc, acc = mapfold (program_desc_it funs) acc p.p_desc in + { p with p_desc = p_desc }, acc + +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 + | 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 + | Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc + let defaults = { app = app; @@ -211,4 +219,5 @@ let defaults = { type_dec = type_dec; tdesc = tdesc; program = program; + program_desc = program_desc; global_funs = Global_mapfold.defaults } diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 0a92b9a..e5f1e75 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -225,10 +225,13 @@ let print_node ff { n_name = n; n_input = ni; n_output = no; print_eqs ne -let print oc { p_opened = pm; p_types = pt; p_nodes = pn; p_consts = pc } = - let ff = formatter_of_out_channel oc in +let print oc { p_opened = pm; p_desc = pd } = + let print_program_desc ff pd = match pd with + | Pnode n -> print_node ff n + | Ptype t -> print_type_dec ff t + | Pconst c -> print_const_dec ff c + in + let ff = formatter_of_out_channel oc in List.iter (print_open_module ff) pm; - List.iter (print_const_dec ff) pc; - List.iter (print_type_dec ff) pt; - List.iter (print_node ff) pn; + List.iter (print_program_desc ff) pd; fprintf ff "@?" diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index f340590..db1f952 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -193,7 +193,13 @@ struct List.map (node_dec_instance n) (get_node_instances n.n_name) let program p = - { p with p_nodes = List.flatten (List.map node_dec p.p_nodes) } + let program_desc pd acc = match pd with + | Pnode n -> + let nds = node_dec n in + List.fold_left (fun pds n -> Pnode n :: pds) acc nds + | _ -> pd :: acc + in + { p with p_desc = List.fold_right program_desc [] p.p_desc } end end @@ -252,7 +258,10 @@ let node_by_longname node = then load_object_file node.qual; try let p = ModulEnv.find node.qual info.opened in - List.find (fun n -> n.n_name = node) p.p_nodes + let n = List.find (function Pnode n -> n.n_name = node | _ -> false) p.p_desc in + (match n with + | Pnode n -> n + | _ -> Misc.internal_error "callgraph" 0) with Not_found -> Error.message no_location (Error.Enode_unbound node) @@ -307,8 +316,9 @@ let rec call_node (ln, params) = let program p = (* Find the nodes without static parameters *) - let main_nodes = List.filter (fun n -> is_empty n.n_params) p.p_nodes in - let main_nodes = List.map (fun n -> n.n_name, []) main_nodes in + let main_nodes = List.filter (function Pnode n -> is_empty n.n_params | _ -> false) p.p_desc in + let main_nodes = List.map (function Pnode n -> n.n_name, [] + | _ -> Misc.internal_error "callgraph" 0) main_nodes in info.opened <- ModulEnv.add p.p_modname p ModulEnv.empty; (* Creates the list of instances starting from these nodes *) List.iter call_node main_nodes; diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index 1edac15..bbfc9cb 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -110,8 +110,11 @@ type class_def = type program = { p_modname : modul; - p_opened : modul list; - p_types : type_dec list; - p_consts : const_dec list; - p_classes : class_def list; } + p_opened : modul list; + p_desc : program_desc list } + +and program_desc = + | Pclass of class_def + | Pconst of const_dec + | Ptype of type_dec diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index 398b4cf..627e180 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -13,25 +13,24 @@ 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.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; - global_funs:'a Global_mapfold.global_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.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; + program_desc: 'a obc_it_funs -> 'a -> Obc.program_desc -> Obc.program_desc * 'a; + global_funs: 'a Global_mapfold.global_it_funs } let rec exp_it funs acc e = funs.exp funs acc e @@ -186,11 +185,16 @@ and tdesc funs acc td = match td with 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_classes in - { p with p_types = td_list; p_consts = cd_list; p_classes = nd_list }, acc + let p_desc, acc = mapfold (program_desc_it funs) acc p.p_desc in + { p with p_desc = p_desc }, acc +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 + | 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 let defaults = { lhs = lhs; @@ -209,4 +213,5 @@ let defaults = { type_dec = type_dec; tdesc = tdesc; program = program; + program_desc = program_desc; global_funs = Global_mapfold.defaults }