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

Use qualnames in Obc too

Browse source
This commit is contained in:
Cédric Pasteur 2010-09-13 09:03:15 +02:00
parent fd4d0942f4
commit 36addab3cc
4 changed files with 29 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
compiler/main/mls2obc.ml
View file

@ -480,7 +480,7 @@ let translate_node
let resetm = {
m_name = Mreset; m_inputs = []; m_outputs = [];
m_body = mk_block si } in
{ cd_name = shortname f; cd_mems = m; cd_params = params;
{ cd_name = f; cd_mems = m; cd_params = params;
cd_objs = j; cd_methods = [stepm; resetm];
cd_loc = loc }
@ -493,11 +493,11 @@ let translate_ty_def { Minils.t_name = name; Minils.t_desc = tdesc;
Type_enum (List.map shortname tag_name_list)
| Minils.Type_struct field_ty_list ->
Type_struct field_ty_list in
{ t_name = shortname name; t_desc = tdesc; t_loc = loc }
{ t_name = name; t_desc = tdesc; t_loc = loc }
let translate_const_def { Minils.c_name = name; Minils.c_value = se;
Minils.c_type = ty; Minils.c_loc = loc } =
{ c_name = shortname name;
{ c_name = name;
c_value = se;
c_type = ty;
c_loc = loc }

32
compiler/obc/c/cmain.ml
View file

@ -32,23 +32,24 @@ let assert_node_res cd =
let stepm = find_step_method cd in
if List.length stepm.m_inputs > 0 then
(Format.eprintf "Cannot generate run-time check for node %s with inputs.@."
cd.cd_name;
(cname_of_qn cd.cd_name);
exit 1);
if (match stepm.m_outputs with
| [{ v_type = Tid nbool; }] when nbool = Initial.pbool -> false
| _ -> true) then
(Format.eprintf
"Cannot generate run-time check for node %s with non-boolean output.@."
cd.cd_name;
(cname_of_qn cd.cd_name);
exit 1);
let name = cname_of_qn cd.cd_name in
let mem =
(name (Idents.fresh ("mem_for_" ^ cd.cd_name)),
Cty_id (cd.cd_name ^ "_mem"))
(Idents.name (Idents.fresh ("mem_for_" ^ name)),
Cty_id (name ^ "_mem"))
and out =
(name (Idents.fresh ("out_for_" ^ cd.cd_name)),
Cty_id (cd.cd_name ^ "_out")) in
(Idents.name (Idents.fresh ("out_for_" ^ name)),
Cty_id (name ^ "_out")) in
let reset_i =
Cfun_call (cd.cd_name ^ "_reset", [Caddrof (Cvar (fst mem))]) in
Cfun_call (name ^ "_reset", [Caddrof (Cvar (fst mem))]) in
let step_i =
(*
step(&out, &mem);
@ -62,15 +63,15 @@ let assert_node_res cd =
{ var_decls = [];
block_body =
[
Csexpr (Cfun_call (cd.cd_name ^ "_step",
Csexpr (Cfun_call (name ^ "_step",
[Caddrof (Cvar (fst out));
Caddrof (Cvar (fst mem))]));
Cif (Cuop ("!", Clhs (Cfield (Cvar (fst out), outn))),
[Csexpr (Cfun_call ("printf",
[Cconst (Cstrlit ("Node \\\"" ^ cd.cd_name
[Cconst (Cstrlit ("Node \\\"" ^ name
^ "\\\" failed at step" ^
" %d.\\n"));
Clhs (Cvar (name step_counter))]));
Clhs (Cvar (Idents.name step_counter))]));
Creturn (Cconst (Ccint 1))],
[]);
];
@ -176,10 +177,10 @@ let main_def_of_class_def cd =
let printf_calls = List.concat printf_calls in
let cinp = cvarlist_of_ovarlist stepm.m_inputs in
let cout = ["res", (Cty_id (cd.cd_name ^ "_out"))] in
let cout = ["res", (Cty_id ((cname_of_qn cd.cd_name) ^ "_out"))] in
let varlist =
("mem", Cty_id (cd.cd_name ^ "_mem"))
("mem", Cty_id ((cname_of_qn cd.cd_name) ^ "_mem"))
:: cinp
@ cout
@ concat scanf_decls
@ -192,7 +193,7 @@ let main_def_of_class_def cd =
let args =
map (fun vd -> Clhs (Cvar (name vd.v_ident))) stepm.m_inputs
@ [Caddrof (Cvar "res"); Caddrof (Cvar "mem")] in
Cfun_call (cd.cd_name ^ "_step", args) in
Cfun_call ((cname_of_qn cd.cd_name) ^ "_step", args) in
concat scanf_calls
@ [Csexpr funcall]
@ printf_calls
@ -201,7 +202,8 @@ let main_def_of_class_def cd =
(** Do not forget to initialize memory via reset. *)
let rst_i =
Csexpr (Cfun_call (cd.cd_name ^ "_reset", [Caddrof (Cvar "mem")])) in
Csexpr (Cfun_call ((cname_of_qn cd.cd_name) ^ "_reset",
[Caddrof (Cvar "mem")])) in
(varlist, rst_i, step_l)
@ -254,7 +256,7 @@ let mk_main name p = match (!Misc.simulation_node, !Misc.assert_nodes) with
| (None, []) -> []
| (_, n_names) ->
let find_class n =
try List.find (fun cd -> cd.cd_name = n) p.p_defs
try List.find (fun cd -> cd.cd_name.name = n) p.p_defs
with Not_found ->
Format.eprintf "Unknown node %s.\n" n;
exit 1 in

6
compiler/obc/obc.ml
View file

@ -15,13 +15,13 @@ open Types
open Signature
open Location
type class_name = name
type class_name = qualname
type instance_name = qualname
type obj_name = name
type op_name = qualname
type type_dec =
{ t_name : name;
{ t_name : qualname;
t_desc : tdesc;
t_loc : location }
@ -32,7 +32,7 @@ and tdesc =
| Type_struct of structure
type const_dec = {
c_name : name;
c_name : qualname;
c_value : static_exp;
c_type : ty;
c_loc : location }

12
compiler/obc/obc_printer.ml
View file

@ -139,7 +139,7 @@ let print_method ff md =
let print_class_def ff
{ cd_name = id; cd_mems = mem; cd_objs = objs; cd_methods = m_list } =
fprintf ff "@[<v 2>machine "; print_name ff id; fprintf ff " =@,";
fprintf ff "@[<v 2>machine "; print_qualname ff id; fprintf ff " =@,";
if mem <> [] then begin
fprintf ff "@[<hov 4>var ";
print_list_r print_vd "" ";" "" ff mem;
@ -156,15 +156,15 @@ let print_class_def ff
let print_type_def ff { t_name = name; t_desc = tdesc } =
match tdesc with
| Type_abs -> fprintf ff "@[type %s@\n@]" name
| Type_abs -> fprintf ff "@[type %a@\n@]" print_qualname name
| Type_alias ty ->
fprintf ff "@[type %s@ = %a@\n@]" name print_type ty
fprintf ff "@[type %a@ = %a@\n@]" print_qualname name print_type ty
| Type_enum(tag_name_list) ->
fprintf ff "@[type %s = " name;
fprintf ff "@[type %a = " print_qualname name;
print_list_r print_name "" "|" "" ff tag_name_list;
fprintf ff "@\n@]"
| Type_struct(f_ty_list) ->
fprintf ff "@[type %s = " name;
fprintf ff "@[type %a = " print_qualname name;
fprintf ff "@[<v 1>";
print_list
(fun ff { Signature.f_name = field; Signature.f_type = ty } ->
@ -179,7 +179,7 @@ let print_open_module ff name =
fprintf ff "@.@]"
let print_const_dec ff c =
fprintf ff "const %a = %a@." print_name c.c_name
fprintf ff "const %a = %a@." print_qualname c.c_name
print_static_exp c.c_value
let print_prog ff { p_opened = modules; p_types = types;