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

Print qualnames with prefix in C code

Browse source 
A qualname is printed as Qual__name
This commit is contained in:
Cédric Pasteur 2010-09-13 09:37:58 +02:00
parent 5da49aa30d
commit 653de74a9d
1 changed files with 39 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

74
compiler/obc/c/cgen.ml
View file

@ -50,6 +50,9 @@ struct
raise Misc.Error
end
let cname_of_qn q =
(q.qual ^ "__" ^ q.name)
let rec struct_name ty =
match ty with
| Cty_id n -> n
@ -92,7 +95,7 @@ let rec ctype_of_otype oty =
| Types.Tid id when id = Initial.pint -> Cty_int
| Types.Tid id when id = Initial.pfloat -> Cty_float
| Types.Tid id when id = Initial.pbool -> Cty_int
| Tid id -> Cty_id (shortname id)
| Tid id -> Cty_id (cname_of_qn id)
| Tarray(ty, n) -> Cty_arr(int_of_static_exp n,
ctype_of_otype ty)
| Tprod _ -> assert false
@ -143,7 +146,7 @@ let rec copy_array src dest bounds =
mapping strings to cty). *)
let rec assoc_type n var_env =
match var_env with
| [] -> (*Error.message no_location (Error.Evar n)*)assert false
| [] -> Error.message no_location (Error.Evar n)
| (vn,ty)::var_env ->
if vn = n then
ty
@ -210,21 +213,21 @@ and create_affect_stm dest src ty =
(** Returns the expression to use e as an argument of
a function expecting a pointer as argument. *)
let address_of e =
try
(* try *)
let lhs = lhs_of_exp e in
match lhs with
| Carray _ -> Clhs lhs
| Cderef lhs -> Clhs lhs
| _ -> Caddrof lhs
with _ ->
e
(* with _ ->
e *)
let rec cexpr_of_static_exp se =
match se.se_desc with
| Sint i -> Cconst (Ccint i)
| Sfloat f -> Cconst (Ccfloat f)
| Sbool b -> Cconst (Ctag (if b then "TRUE" else "FALSE"))
| Sconstructor c -> Cconst (Ctag (shortname c))
| Sconstructor c -> Cconst (Ctag (cname_of_qn c))
| Sarray sl -> Carraylit (List.map cexpr_of_static_exp sl)
| Sarray_power(n,c) ->
let cc = cexpr_of_static_exp c in
@ -256,7 +259,7 @@ let rec cexpr_of_exp var_env exp =
(** Structure literals. *)
| Estruct (tyn, fl) ->
let cexps = List.map (fun (_,e) -> cexpr_of_exp var_env e) fl in
let ctyn = shortname tyn in
let ctyn = cname_of_qn tyn in
Cstructlit (ctyn, cexps)
| Earray e_list ->
Carraylit (cexprs_of_exps var_env e_list)
@ -353,7 +356,7 @@ let step_fun_call var_env sig_info objn out args =
let generate_function_call var_env obj_env outvl objn args =
(** Class name for the object to step. *)
let classln = assoc_cn objn obj_env in
let classn = shortname classln in
let classn = cname_of_qn classln in
let sig_info = find_value classln in
let out = Cvar (out_var_name_of_objn classn) in
@ -420,7 +423,7 @@ let rec cstm_of_act var_env obj_env act =
(** [ccl_of_obccl] translates an Obc clause to a C clause. *)
let ccl =
List.map
(fun (c,act) -> shortname c,
(fun (c,act) -> cname_of_qn c,
cstm_of_act_list var_env obj_env act) cl in
[Cswitch (cexpr_of_exp var_env e, ccl)]
@ -435,7 +438,7 @@ let rec cstm_of_act var_env obj_env act =
| Acall ([], o, Mreset, []) ->
let on = obj_call_name o in
let obj = assoc_obj on obj_env in
let classn = shortname obj.o_class in
let classn = cname_of_qn obj.o_class in
(match obj.o_size with
| None -> [Csexpr (Cfun_call (classn ^ "_reset",
[Caddrof (Cfield (Cderef (Cvar "self"), on))]))]
@ -490,10 +493,10 @@ let mk_current_longname n =
(** Builds the argument list of step function*)
let step_fun_args n md =
let args = cvarlist_of_ovarlist md.m_inputs in
let out_arg = [("out", Cty_ptr (Cty_id (n ^ "_out")))] in
let out_arg = [("out", Cty_ptr (Cty_id ((cname_of_qn n) ^ "_out")))] in
let context_arg =
if is_statefull (mk_current_longname n) then
[("self", Cty_ptr (Cty_id (n ^ "_mem")))]
if is_statefull n then
[("self", Cty_ptr (Cty_id ((cname_of_qn n) ^ "_mem")))]
else
[]
in
@ -506,17 +509,17 @@ let step_fun_args n md =
reset calls. A step function can have multiple return values, whereas C does
not allow such functions. When it is the case, we declare a structure with a
field by return value. *)
let fun_def_of_step_fun name obj_env mem objs md =
let fun_name = name ^ "_step" in
let fun_def_of_step_fun n obj_env mem objs md =
let fun_name = (cname_of_qn n) ^ "_step" in
(** Its arguments, translating Obc types to C types and adding our internal
memory structure. *)
let args = step_fun_args name md in
let args = step_fun_args n md in
(** Out vars for function calls *)
let out_vars =
unique
(List.map (fun obj -> out_var_name_of_objn (shortname obj.o_class),
Cty_id ((shortname obj.o_class) ^ "_out"))
(List.map (fun obj -> out_var_name_of_objn (cname_of_qn obj.o_class),
Cty_id ((cname_of_qn obj.o_class) ^ "_out"))
(List.filter (fun obj -> not (is_op obj.o_class)) objs)) in
(** The body *)
@ -546,7 +549,7 @@ let mem_decl_of_class_def cd =
convention we described above. *)
let struct_field_of_obj_dec l od =
if is_statefull od.o_class then
let clsname = shortname od.o_class in
let clsname = cname_of_qn od.o_class in
let ty = Cty_id (clsname ^ "_mem") in
let ty = match od.o_size with
| Some se -> Cty_arr (int_of_static_exp se, ty)
@ -555,12 +558,13 @@ let mem_decl_of_class_def cd =
else
l
in
if is_statefull (mk_current_longname cd.cd_name) then (
if is_statefull cd.cd_name then (
(** Fields corresponding to normal memory variables. *)
let mem_fields = List.map cvar_of_vd cd.cd_mems in
(** Fields corresponding to object variables. *)
let obj_fields = List.fold_left struct_field_of_obj_dec [] cd.cd_objs in
[Cdecl_struct (cd.cd_name ^ "_mem", mem_fields @ obj_fields)]
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_mem",
mem_fields @ obj_fields)]
) else
[]
@ -568,7 +572,7 @@ let out_decl_of_class_def cd =
(** Fields corresponding to output variables. *)
let step_m = find_step_method cd in
let out_fields = List.map cvar_of_vd step_m.m_outputs in
[Cdecl_struct (cd.cd_name ^ "_out", out_fields)]
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_out", out_fields)]
(** [reset_fun_def_of_class_def cd] returns the defintion of the C function
tasked to reset the class [cd]. *)
@ -577,9 +581,9 @@ let reset_fun_def_of_class_def cd =
let reset = find_reset_method cd in
let body = cstm_of_act_list var_env cd.cd_objs reset.m_body in
Cfundef {
f_name = (cd.cd_name ^ "_reset");
f_name = (cname_of_qn cd.cd_name) ^ "_reset";
f_retty = Cty_void;
f_args = [("self", Cty_ptr (Cty_id (cd.cd_name ^ "_mem")))];
f_args = [("self", Cty_ptr (Cty_id ((cname_of_qn cd.cd_name) ^ "_mem")))];
f_body = {
var_decls = [];
block_body = body;
@ -595,14 +599,14 @@ let cdefs_and_cdecls_of_class_def cd =
let step_m = find_step_method cd in
let memory_struct_decl = mem_decl_of_class_def cd in
let out_struct_decl = out_decl_of_class_def cd in
let step_fun_def
= fun_def_of_step_fun cd.cd_name cd.cd_objs cd.cd_mems cd.cd_objs step_m in
let step_fun_def = fun_def_of_step_fun cd.cd_name
cd.cd_objs cd.cd_mems cd.cd_objs step_m in
(** C function for resetting our memory structure. *)
let reset_fun_def = reset_fun_def_of_class_def cd in
let res_fun_decl = cdecl_of_cfundef reset_fun_def in
let step_fun_decl = cdecl_of_cfundef step_fun_def in
let (decls, defs) =
if is_statefull (mk_current_longname cd.cd_name) then
if is_statefull cd.cd_name then
([res_fun_decl; step_fun_decl], [reset_fun_def; step_fun_def])
else
([step_fun_decl], [step_fun_def]) in
@ -614,13 +618,13 @@ let cdefs_and_cdecls_of_class_def cd =
let decls_of_type_decl otd =
let name = otd.t_name in
let name = cname_of_qn otd.t_name in
match otd.t_desc with
| Type_abs -> [] (*assert false*)
| Type_alias ty -> [Cdecl_typedef (ctype_of_otype ty, name)]
| Type_enum nl ->
let name = !global_name ^ "_" ^ name in
[Cdecl_enum (otd.t_name, nl);
[Cdecl_enum (name, nl);
Cdecl_function (name ^ "_of_string",
Cty_id name,
[("s", Cty_ptr Cty_char)]);
@ -628,13 +632,13 @@ let decls_of_type_decl otd =
Cty_ptr Cty_char,
[("x", Cty_id name); ("buf", Cty_ptr Cty_char)])]
| Type_struct fl ->
let decls = List.map (fun f -> shortname f.Signature.f_name,
let decls = List.map (fun f -> cname_of_qn f.Signature.f_name,
ctype_of_otype f.Signature.f_type) fl in
[Cdecl_struct (otd.t_name, decls)];;
[Cdecl_struct (name, decls)];;
(** Translates an Obc type declaration to its C counterpart. *)
let cdefs_and_cdecls_of_type_decl otd =
let name = otd.t_name in
let name = cname_of_qn otd.t_name in
match otd.t_desc with
| Type_abs -> [], [] (*assert false*)
| Type_alias ty -> [], [Cdecl_typedef (ctype_of_otype ty, name)]
@ -669,12 +673,12 @@ let cdefs_and_cdecls_of_type_decl otd =
Creturn (Clhs (Cvar "buf"))]; }
} in
([of_string_fun; to_string_fun],
[Cdecl_enum (otd.t_name, nl); cdecl_of_cfundef of_string_fun;
[Cdecl_enum (name, nl); cdecl_of_cfundef of_string_fun;
cdecl_of_cfundef to_string_fun])
| Type_struct fl ->
let decls = List.map (fun f -> shortname f.Signature.f_name,
let decls = List.map (fun f -> cname_of_qn f.Signature.f_name,
ctype_of_otype f.Signature.f_type) fl in
let decl = Cdecl_struct (otd.t_name, decls) in
let decl = Cdecl_struct (name, decls) in
([], [decl])
(** [cfile_list_of_oprog oprog] translates the Obc program [oprog] to a list of