jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

no order in declarations

Browse source
This commit is contained in:
Leonard Gerard 2011-04-18 19:20:03 +02:00
parent 03f0d5d89a
commit 8da5ce4648
19 changed files with 212 additions and 203 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
compiler/heptagon/analysis/causality.ml
View file

@ -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

4
compiler/heptagon/analysis/initialization.ml
View file

@ -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

12
compiler/heptagon/analysis/typing.ml
View file

@ -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 }

15
compiler/heptagon/hept_mapfold.ml
View file

@ -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 }

18
compiler/heptagon/hept_printer.ml
View file

@ -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 "@?"

10
compiler/heptagon/heptagon.ml
View file

@ -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;

43
compiler/heptagon/parsing/hept_parser.mly
View file

@ -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

14
compiler/heptagon/parsing/hept_parsetree.ml
View file

@ -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;

109
compiler/heptagon/parsing/hept_parsetree_mapfold.ml
View file

@ -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 }

14
compiler/heptagon/parsing/hept_scoping.ml
View file

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

4
compiler/heptagon/transformations/automata.ml
View file

@ -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 }

4
compiler/heptagon/transformations/itfusion.ml
View file

@ -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 }

45
compiler/main/mls2obc.ml
View file

@ -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 }

9
compiler/minils/minils.ml
View file

@ -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*)

17
compiler/minils/mls_mapfold.ml
View file

@ -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 }

13
compiler/minils/mls_printer.ml
View file

@ -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 "@?"

18
compiler/minils/transformations/callgraph.ml
View file

@ -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;

11
compiler/obc/obc.ml
View file

@ -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

51
compiler/obc/obc_mapfold.ml
View file

@ -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 }