2010-06-15 10:49:03 +02:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon *)
|
|
|
|
(* *)
|
|
|
|
(* Author : Marc Pouzet *)
|
|
|
|
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
|
|
|
|
|
|
|
open Format
|
|
|
|
open List
|
|
|
|
open Misc
|
|
|
|
open Names
|
2010-07-23 19:45:19 +02:00
|
|
|
open Idents
|
2010-06-15 10:49:03 +02:00
|
|
|
open Obc
|
2011-03-08 09:22:02 +01:00
|
|
|
open Obc_utils
|
2010-07-09 09:31:12 +02:00
|
|
|
open Types
|
2010-07-27 16:27:07 +02:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
open Modules
|
2010-06-18 10:55:16 +02:00
|
|
|
open Signature
|
2010-06-15 10:49:03 +02:00
|
|
|
open C
|
|
|
|
open Location
|
2010-08-24 17:23:50 +02:00
|
|
|
open Format
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
module Error =
|
|
|
|
struct
|
|
|
|
type error =
|
|
|
|
| Evar of string
|
|
|
|
| Enode of string
|
|
|
|
| Eno_unnamed_output
|
2010-06-16 11:32:13 +02:00
|
|
|
| Ederef_not_pointer
|
2010-07-16 12:04:51 +02:00
|
|
|
| Estatic_exp_compute_failed
|
2010-09-13 13:32:35 +02:00
|
|
|
| Eunknown_method of string
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-27 17:24:31 +02:00
|
|
|
let message loc kind = (match kind with
|
|
|
|
| Evar name ->
|
2010-09-01 13:31:28 +02:00
|
|
|
eprintf "%aCode generation : The variable name '%s' is unbound.@."
|
2010-08-24 17:23:50 +02:00
|
|
|
print_location loc name
|
2010-06-27 17:24:31 +02:00
|
|
|
| Enode name ->
|
2010-09-01 13:31:28 +02:00
|
|
|
eprintf "%aCode generation : The node name '%s' is unbound.@."
|
2010-08-24 17:23:50 +02:00
|
|
|
print_location loc name
|
2010-06-27 17:24:31 +02:00
|
|
|
| Eno_unnamed_output ->
|
2010-09-01 13:31:28 +02:00
|
|
|
eprintf "%aCode generation : Unnamed outputs are not supported.@."
|
2010-08-24 17:23:50 +02:00
|
|
|
print_location loc
|
2010-06-27 17:24:31 +02:00
|
|
|
| Ederef_not_pointer ->
|
2010-09-01 13:31:28 +02:00
|
|
|
eprintf "%aCode generation : Trying to deference a non pointer type.@."
|
2010-08-24 17:23:50 +02:00
|
|
|
print_location loc
|
2010-07-16 12:04:51 +02:00
|
|
|
| Estatic_exp_compute_failed ->
|
|
|
|
eprintf "%aCode generation : Computation of the value of the static \
|
2010-09-01 13:31:28 +02:00
|
|
|
expression failed.@."
|
2010-09-13 13:32:35 +02:00
|
|
|
print_location loc
|
|
|
|
| Eunknown_method s ->
|
|
|
|
eprintf "%aCode generation : Methods other than step and \
|
|
|
|
reset are not supported (found '%s').@."
|
|
|
|
print_location loc
|
|
|
|
s);
|
2010-09-15 09:38:52 +02:00
|
|
|
raise Errors.Error
|
2010-06-15 10:49:03 +02:00
|
|
|
end
|
|
|
|
|
2010-06-26 16:53:25 +02:00
|
|
|
let rec struct_name ty =
|
2010-06-16 11:32:13 +02:00
|
|
|
match ty with
|
2010-06-27 17:24:31 +02:00
|
|
|
| Cty_id n -> n
|
|
|
|
| _ -> assert false
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-07-09 09:31:12 +02:00
|
|
|
let int_of_static_exp se =
|
2010-09-10 11:53:55 +02:00
|
|
|
Static.int_of_static_exp QualEnv.empty se
|
2010-07-09 09:31:12 +02:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
let output_names_list sig_info =
|
2010-06-15 10:49:03 +02:00
|
|
|
let remove_option ad = match ad.a_name with
|
2011-04-27 14:02:50 +02:00
|
|
|
| Some n -> n
|
2010-06-16 11:32:13 +02:00
|
|
|
| None -> Error.message no_location Error.Eno_unnamed_output
|
2010-06-15 10:49:03 +02:00
|
|
|
in
|
2010-09-10 11:53:55 +02:00
|
|
|
List.map remove_option sig_info.node_outputs
|
2010-06-18 10:55:16 +02:00
|
|
|
|
2011-03-21 14:30:19 +01:00
|
|
|
let is_stateful n =
|
2010-06-30 17:30:24 +02:00
|
|
|
try
|
2010-09-10 11:53:55 +02:00
|
|
|
let sig_info = find_value n in
|
2011-03-21 14:30:19 +01:00
|
|
|
sig_info.node_stateful
|
2010-06-30 17:30:24 +02:00
|
|
|
with
|
|
|
|
Not_found -> Error.message no_location (Error.Enode (fullname n))
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(******************************)
|
|
|
|
|
|
|
|
(** {2 Translation from Obc to C using our AST.} *)
|
|
|
|
|
|
|
|
(** [fold_stm_list] is an utility function that transforms a list of statements
|
|
|
|
into one statements using Cseq constructors. *)
|
|
|
|
|
|
|
|
(** [ctype_of_type mods oty] translates the Obc type [oty] to a C
|
|
|
|
type. We assume that identified types have already been defined
|
|
|
|
before use. [mods] is an accumulator for modules to be opened for
|
2010-06-16 11:32:13 +02:00
|
|
|
each function (i.e., not opened by an "open" declaration).
|
2010-06-15 10:49:03 +02:00
|
|
|
We have to make a difference between function args and local vars
|
|
|
|
because of arrays (when used as args, we use a pointer).
|
|
|
|
*)
|
|
|
|
let rec ctype_of_otype oty =
|
|
|
|
match oty with
|
2010-07-09 09:31:12 +02:00
|
|
|
| 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
|
2010-09-13 15:16:12 +02:00
|
|
|
| Tid id -> Cty_id id
|
2011-03-21 14:30:19 +01:00
|
|
|
| Tarray(ty, n) -> Cty_arr(int_of_static_exp n, ctype_of_otype ty)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Tprod _ -> assert false
|
2011-04-14 18:06:54 +02:00
|
|
|
| Tinvalid -> assert false
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
let cvarlist_of_ovarlist vl =
|
|
|
|
let cvar_of_ovar vd =
|
|
|
|
let ty = ctype_of_otype vd.v_type in
|
2010-06-27 17:24:31 +02:00
|
|
|
name vd.v_ident, ty
|
2010-06-15 10:49:03 +02:00
|
|
|
in
|
2010-06-16 11:32:13 +02:00
|
|
|
List.map cvar_of_ovar vl
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
let copname = function
|
|
|
|
| "=" -> "==" | "<>" -> "!=" | "&" -> "&&" | "or" -> "||" | "+" -> "+"
|
|
|
|
| "-" -> "-" | "*" -> "*" | "/" -> "/" | "*." -> "*" | "/." -> "/"
|
|
|
|
| "+." -> "+" | "-." -> "-" | "<" -> "<" | ">" -> ">" | "<=" -> "<="
|
|
|
|
| ">=" -> ">="
|
2010-10-02 12:59:44 +02:00
|
|
|
| "~-" -> "-" | "not" -> "!" | "%" -> "%"
|
2010-06-15 10:49:03 +02:00
|
|
|
| op -> op
|
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Translates an Obc var_dec to a tuple (name, cty). *)
|
2010-06-15 10:49:03 +02:00
|
|
|
let cvar_of_vd vd =
|
2010-06-27 17:24:31 +02:00
|
|
|
name vd.v_ident, ctype_of_otype vd.v_type
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** If idx_list = [e1;..;ep], returns the lhs e[e1]...[ep] *)
|
2010-06-16 11:32:13 +02:00
|
|
|
let rec csubscript_of_e_list e idx_list =
|
2010-06-15 10:49:03 +02:00
|
|
|
match idx_list with
|
|
|
|
| [] -> e
|
|
|
|
| idx::idx_list ->
|
2010-06-16 11:32:13 +02:00
|
|
|
Carray (csubscript_of_e_list e idx_list, idx)
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** If idx_list = [i1;..;ip], returns the lhs e[i1]...[ip] *)
|
2010-06-16 11:32:13 +02:00
|
|
|
let csubscript_of_idx_list e idx_list =
|
2010-06-15 10:49:03 +02:00
|
|
|
csubscript_of_e_list e (List.map (fun i -> Cconst (Ccint i)) idx_list)
|
|
|
|
|
|
|
|
(** Generate the expression to copy [src] into [dest], where bounds
|
|
|
|
represents the bounds of these two arrays. *)
|
2010-06-16 11:32:13 +02:00
|
|
|
let rec copy_array src dest bounds =
|
2010-06-15 10:49:03 +02:00
|
|
|
match bounds with
|
|
|
|
| [] -> [Caffect (dest, Clhs src)]
|
2010-06-16 11:32:13 +02:00
|
|
|
| n::bounds ->
|
|
|
|
let x = gen_symbol () in
|
2011-04-18 15:38:42 +02:00
|
|
|
[Cfor(x, Cconst (Ccint 0), n,
|
2010-06-16 11:32:13 +02:00
|
|
|
copy_array (Carray (src, Clhs (Cvar x)))
|
|
|
|
(Carray (dest, Clhs (Cvar x))) bounds)]
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** Returns the type associated with the name [n]
|
|
|
|
in the environnement [var_env] (which is an association list
|
|
|
|
mapping strings to cty). *)
|
|
|
|
let rec assoc_type n var_env =
|
|
|
|
match var_env with
|
2010-09-13 09:37:58 +02:00
|
|
|
| [] -> Error.message no_location (Error.Evar n)
|
2010-06-15 10:49:03 +02:00
|
|
|
| (vn,ty)::var_env ->
|
2010-06-16 11:32:13 +02:00
|
|
|
if vn = n then
|
|
|
|
ty
|
|
|
|
else
|
|
|
|
assoc_type n var_env
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-07-26 17:41:52 +02:00
|
|
|
(** @return the unaliased version of a type. *)
|
|
|
|
let rec unalias_ctype = function
|
|
|
|
| Cty_id ty_name ->
|
|
|
|
(try
|
2010-09-13 15:16:12 +02:00
|
|
|
match find_type ty_name with
|
2010-09-10 14:29:13 +02:00
|
|
|
| Talias ty -> unalias_ctype (ctype_of_otype ty)
|
|
|
|
| _ -> Cty_id ty_name
|
2010-07-26 17:41:52 +02:00
|
|
|
with Not_found -> Cty_id ty_name)
|
|
|
|
| Cty_arr (n, cty) -> Cty_arr (n, unalias_ctype cty)
|
|
|
|
| Cty_ptr cty -> Cty_ptr (unalias_ctype cty)
|
|
|
|
| cty -> cty
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** Returns the type associated with the lhs [lhs]
|
|
|
|
in the environnement [var_env] (which is an association list
|
|
|
|
mapping strings to cty).*)
|
|
|
|
let rec assoc_type_lhs lhs var_env =
|
|
|
|
match lhs with
|
2010-07-26 17:41:52 +02:00
|
|
|
| Cvar x -> unalias_ctype (assoc_type x var_env)
|
2010-06-16 11:32:13 +02:00
|
|
|
| Carray (lhs, _) ->
|
|
|
|
let ty = assoc_type_lhs lhs var_env in
|
|
|
|
array_base_ctype ty [1]
|
2010-06-26 16:53:25 +02:00
|
|
|
| Cderef lhs ->
|
|
|
|
(match assoc_type_lhs lhs var_env with
|
2010-06-27 17:24:31 +02:00
|
|
|
| Cty_ptr ty -> ty
|
|
|
|
| _ -> Error.message no_location Error.Ederef_not_pointer)
|
2010-09-13 15:16:12 +02:00
|
|
|
| Cfield(Cderef (Cvar "self"), { name = x }) -> assoc_type x var_env
|
2010-06-15 10:49:03 +02:00
|
|
|
| Cfield(x, f) ->
|
2010-06-16 11:32:13 +02:00
|
|
|
let ty = assoc_type_lhs x var_env in
|
|
|
|
let n = struct_name ty in
|
2010-09-13 15:16:12 +02:00
|
|
|
let fields = find_struct n in
|
|
|
|
ctype_of_otype (field_assoc f fields)
|
2010-06-16 11:32:13 +02:00
|
|
|
|
|
|
|
(** Creates the statement a = [e_1, e_2, ..], which gives a list
|
|
|
|
a[i] = e_i.*)
|
2010-06-26 16:53:25 +02:00
|
|
|
let rec create_affect_lit dest l ty =
|
2010-06-16 11:32:13 +02:00
|
|
|
let rec _create_affect_lit dest i = function
|
|
|
|
| [] -> []
|
2010-06-26 16:53:25 +02:00
|
|
|
| v::l ->
|
|
|
|
let stm = create_affect_stm (Carray (dest, Cconst (Ccint i))) v ty in
|
|
|
|
stm@(_create_affect_lit dest (i+1) l)
|
2010-06-16 11:32:13 +02:00
|
|
|
in
|
2010-06-26 16:53:25 +02:00
|
|
|
_create_affect_lit dest 0 l
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** Creates the expression dest <- src (copying arrays if necessary). *)
|
2010-06-16 11:32:13 +02:00
|
|
|
and create_affect_stm dest src ty =
|
2010-10-02 12:59:44 +02:00
|
|
|
match ty with
|
2010-06-15 10:49:03 +02:00
|
|
|
| Cty_arr (n, bty) ->
|
2010-06-26 16:53:25 +02:00
|
|
|
(match src with
|
|
|
|
| Carraylit l -> create_affect_lit dest l bty
|
|
|
|
| Clhs src ->
|
2010-06-16 11:32:13 +02:00
|
|
|
let x = gen_symbol () in
|
2011-04-18 15:38:42 +02:00
|
|
|
[Cfor(x, Cconst (Ccint 0), Cconst (Ccint n),
|
2010-06-26 16:53:25 +02:00
|
|
|
create_affect_stm (Carray (dest, Clhs (Cvar x)))
|
|
|
|
(Clhs (Carray (src, Clhs (Cvar x)))) bty)]
|
2010-09-13 13:32:35 +02:00
|
|
|
| _ -> assert false (** TODO: add missing cases eg for records *)
|
2010-06-26 16:53:25 +02:00
|
|
|
)
|
2010-10-02 13:19:21 +02:00
|
|
|
| Cty_id ln ->
|
|
|
|
(match src with
|
|
|
|
| Cstructlit (_, ce_list) ->
|
|
|
|
let create_affect { f_name = f_name;
|
|
|
|
Signature.f_type = f_type; } e stm_list =
|
|
|
|
let cty = ctype_of_otype f_type in
|
|
|
|
create_affect_stm (Cfield (dest, f_name)) e cty @ stm_list in
|
|
|
|
List.fold_right2 create_affect (find_struct ln) ce_list []
|
|
|
|
| _ -> [Caffect (dest, src)])
|
2010-06-15 10:49:03 +02:00
|
|
|
| _ -> [Caffect (dest, src)]
|
|
|
|
|
|
|
|
(** Returns the expression to use e as an argument of
|
|
|
|
a function expecting a pointer as argument. *)
|
|
|
|
let address_of e =
|
2010-09-13 09:37:58 +02:00
|
|
|
(* try *)
|
2010-06-15 10:49:03 +02:00
|
|
|
let lhs = lhs_of_exp e in
|
2010-06-16 11:32:13 +02:00
|
|
|
match lhs with
|
|
|
|
| Carray _ -> Clhs lhs
|
|
|
|
| Cderef lhs -> Clhs lhs
|
|
|
|
| _ -> Caddrof lhs
|
2010-09-13 09:37:58 +02:00
|
|
|
(* with _ ->
|
|
|
|
e *)
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-07-13 16:23:26 +02:00
|
|
|
let rec cexpr_of_static_exp se =
|
|
|
|
match se.se_desc with
|
|
|
|
| Sint i -> Cconst (Ccint i)
|
|
|
|
| Sfloat f -> Cconst (Ccfloat f)
|
2010-11-04 18:06:11 +01:00
|
|
|
| Sbool b -> Cconst (Ctag (if b then "true" else "false"))
|
2011-05-10 16:55:46 +02:00
|
|
|
| Sstring s -> Cconst (Cstrlit s)
|
2010-09-14 09:39:02 +02:00
|
|
|
| Sfield _ -> assert false
|
2010-09-13 09:37:58 +02:00
|
|
|
| Sconstructor c -> Cconst (Ctag (cname_of_qn c))
|
2010-07-19 15:16:14 +02:00
|
|
|
| Sarray sl -> Carraylit (List.map cexpr_of_static_exp sl)
|
2011-01-18 17:52:44 +01:00
|
|
|
| Srecord fl ->
|
|
|
|
let ty_name =
|
|
|
|
match Modules.unalias_type se.se_ty with
|
|
|
|
| Types.Tid n -> cname_of_qn n
|
|
|
|
| _ -> assert false
|
|
|
|
in
|
|
|
|
Cstructlit (ty_name,
|
|
|
|
List.map (fun (_, se) -> cexpr_of_static_exp se) fl)
|
2011-05-03 13:21:27 +02:00
|
|
|
| Sarray_power(c,n) ->
|
2010-07-13 16:23:26 +02:00
|
|
|
let cc = cexpr_of_static_exp c in
|
2011-03-17 17:11:00 +01:00
|
|
|
Carraylit (repeat_list cc (int_of_static_exp n)) (* TODO should be recursive *)
|
2010-07-13 16:23:26 +02:00
|
|
|
| Svar ln ->
|
|
|
|
(try
|
2010-09-10 14:29:13 +02:00
|
|
|
let cd = find_const ln in
|
2010-10-02 12:59:44 +02:00
|
|
|
cexpr_of_static_exp (Static.simplify QualEnv.empty cd.c_value)
|
2010-07-13 16:23:26 +02:00
|
|
|
with Not_found -> assert false)
|
2010-07-16 12:04:51 +02:00
|
|
|
| Sop _ ->
|
2010-09-10 14:29:13 +02:00
|
|
|
let se' = Static.simplify QualEnv.empty se in
|
2010-07-16 12:04:51 +02:00
|
|
|
if se = se' then
|
|
|
|
Error.message se.se_loc Error.Estatic_exp_compute_failed
|
|
|
|
else
|
|
|
|
cexpr_of_static_exp se'
|
2010-09-13 13:32:35 +02:00
|
|
|
| Stuple _ -> assert false (** TODO *)
|
2011-01-18 17:52:44 +01:00
|
|
|
|
2010-07-13 16:23:26 +02:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *)
|
|
|
|
let rec cexpr_of_exp var_env exp =
|
2010-07-09 09:31:12 +02:00
|
|
|
match exp.e_desc with
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Obj expressions that form valid C lhs are translated via clhs_of_exp. *)
|
2011-01-24 16:07:26 +01:00
|
|
|
| Epattern _ ->
|
2010-06-15 10:49:03 +02:00
|
|
|
Clhs (clhs_of_exp var_env exp)
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Constants, the easiest translation. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Econst lit ->
|
2010-07-13 16:23:26 +02:00
|
|
|
cexpr_of_static_exp lit
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Operators *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Eop(op, exps) ->
|
2010-06-15 10:49:03 +02:00
|
|
|
cop_of_op var_env op exps
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Structure literals. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Estruct (tyn, fl) ->
|
2010-06-15 10:49:03 +02:00
|
|
|
let cexps = List.map (fun (_,e) -> cexpr_of_exp var_env e) fl in
|
2010-09-13 09:37:58 +02:00
|
|
|
let ctyn = cname_of_qn tyn in
|
2010-06-26 16:53:25 +02:00
|
|
|
Cstructlit (ctyn, cexps)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Earray e_list ->
|
2010-06-16 11:32:13 +02:00
|
|
|
Carraylit (cexprs_of_exps var_env e_list)
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
and cexprs_of_exps var_env exps =
|
2010-06-16 11:32:13 +02:00
|
|
|
List.map (cexpr_of_exp var_env) exps
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-09-14 09:39:02 +02:00
|
|
|
and cop_of_op_aux op_name cexps = match op_name with
|
2011-02-07 14:24:17 +01:00
|
|
|
| { qual = Pervasives; name = op } ->
|
2010-06-16 11:32:13 +02:00
|
|
|
begin match op,cexps with
|
|
|
|
| "~-", [e] -> Cuop ("-", e)
|
|
|
|
| "not", [e] -> Cuop ("!", e)
|
|
|
|
| (
|
|
|
|
"=" | "<>"
|
|
|
|
| "&" | "or"
|
|
|
|
| "+" | "-" | "*" | "/"
|
2010-10-02 12:59:44 +02:00
|
|
|
| "*." | "/." | "+." | "-." | "%"
|
2010-06-16 11:32:13 +02:00
|
|
|
| "<" | ">" | "<=" | ">="), [el;er] ->
|
|
|
|
Cbop (copname op, el, er)
|
|
|
|
| _ -> Cfun_call(op, cexps)
|
|
|
|
end
|
2011-01-11 14:46:28 +01:00
|
|
|
| {qual = m; name = op} -> Cfun_call(op,cexps)
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
and cop_of_op var_env op_name exps =
|
2010-06-15 10:49:03 +02:00
|
|
|
let cexps = cexprs_of_exps var_env exps in
|
2010-09-14 09:39:02 +02:00
|
|
|
cop_of_op_aux op_name cexps
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-11-05 15:36:11 +01:00
|
|
|
and clhs_of_lhs var_env l = match l.pat_desc with
|
2010-06-26 16:53:25 +02:00
|
|
|
(** Each Obc variable corresponds to a real local C variable. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Lvar v ->
|
2010-06-15 10:49:03 +02:00
|
|
|
let n = name v in
|
2010-06-26 16:53:25 +02:00
|
|
|
if List.mem_assoc n var_env then
|
|
|
|
let ty = assoc_type n var_env in
|
|
|
|
(match ty with
|
|
|
|
| Cty_ptr _ -> Cderef (Cvar n)
|
|
|
|
| _ -> Cvar n
|
|
|
|
)
|
|
|
|
else
|
|
|
|
Cvar n
|
2010-06-18 10:55:16 +02:00
|
|
|
(** Dereference our [self] struct holding the node's memory. *)
|
2010-09-13 15:16:12 +02:00
|
|
|
| Lmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v))
|
2010-06-26 16:53:25 +02:00
|
|
|
(** Field access. /!\ Indexed Obj expression should be a valid lhs! *)
|
2010-09-13 15:16:12 +02:00
|
|
|
| Lfield (l, fn) -> Cfield(clhs_of_lhs var_env l, fn)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Larray (l, idx) ->
|
2010-06-16 11:32:13 +02:00
|
|
|
Carray(clhs_of_lhs var_env l, cexpr_of_exp var_env idx)
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
and clhss_of_lhss var_env lhss =
|
|
|
|
List.map (clhs_of_lhs var_env) lhss
|
|
|
|
|
2010-07-09 09:31:12 +02:00
|
|
|
and clhs_of_exp var_env exp = match exp.e_desc with
|
2011-01-24 16:07:26 +01:00
|
|
|
| Epattern l -> clhs_of_lhs var_env l
|
2010-06-26 16:53:25 +02:00
|
|
|
(** We were passed an expression that is not translatable to a valid C lhs?!*)
|
2010-06-15 10:49:03 +02:00
|
|
|
| _ -> invalid_arg "clhs_of_exp: argument not a Var, Mem or Field"
|
|
|
|
|
|
|
|
let rec assoc_obj instance obj_env =
|
|
|
|
match obj_env with
|
|
|
|
| [] -> raise Not_found
|
|
|
|
| od :: t ->
|
2011-03-08 09:22:02 +01:00
|
|
|
if od.o_ident = instance
|
2010-06-15 10:49:03 +02:00
|
|
|
then od
|
|
|
|
else assoc_obj instance t
|
|
|
|
|
|
|
|
let assoc_cn instance obj_env =
|
2010-11-05 15:36:11 +01:00
|
|
|
(assoc_obj (obj_ref_name instance) obj_env).o_class
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
let is_op = function
|
2011-02-07 14:24:17 +01:00
|
|
|
| { qual = Pervasives; name = _ } -> true
|
2010-06-15 10:49:03 +02:00
|
|
|
| _ -> false
|
|
|
|
|
2010-06-30 17:30:24 +02:00
|
|
|
let out_var_name_of_objn o =
|
|
|
|
o ^"_out_st"
|
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Creates the list of arguments to call a node. [targeting] is the targeting
|
|
|
|
of the called node, [mem] represents the node context and [args] the
|
|
|
|
argument list.*)
|
2010-06-30 17:30:24 +02:00
|
|
|
let step_fun_call var_env sig_info objn out args =
|
2011-03-21 14:30:19 +01:00
|
|
|
if sig_info.node_stateful then (
|
2010-06-30 17:30:24 +02:00
|
|
|
let mem =
|
|
|
|
(match objn with
|
2011-03-08 09:22:02 +01:00
|
|
|
| Oobj o -> Cfield (Cderef (Cvar "self"), local_qn (name o))
|
2010-07-09 09:31:12 +02:00
|
|
|
| Oarray (o, l) ->
|
2010-06-30 17:30:24 +02:00
|
|
|
let l = clhs_of_lhs var_env l in
|
2011-03-08 09:22:02 +01:00
|
|
|
Carray (Cfield (Cderef (Cvar "self"), local_qn (name o)), Clhs l)
|
2010-06-30 17:30:24 +02:00
|
|
|
) in
|
|
|
|
args@[Caddrof out; Caddrof mem]
|
|
|
|
) else
|
|
|
|
args@[Caddrof out]
|
2010-06-16 11:32:13 +02:00
|
|
|
|
|
|
|
(** Generate the statement to call [objn].
|
|
|
|
[outvl] is a list of lhs where to put the results.
|
2010-06-15 10:49:03 +02:00
|
|
|
[args] is the list of expressions to use as arguments.
|
|
|
|
[mem] is the lhs where is stored the node's context.*)
|
2010-06-16 11:32:13 +02:00
|
|
|
let generate_function_call var_env obj_env outvl objn args =
|
2010-06-26 16:53:25 +02:00
|
|
|
(** Class name for the object to step. *)
|
2010-06-15 10:49:03 +02:00
|
|
|
let classln = assoc_cn objn obj_env in
|
2010-09-13 09:37:58 +02:00
|
|
|
let classn = cname_of_qn classln in
|
2010-09-10 11:53:55 +02:00
|
|
|
let sig_info = find_value classln in
|
2010-06-30 17:30:24 +02:00
|
|
|
let out = Cvar (out_var_name_of_objn classn) in
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
let fun_call =
|
2010-06-15 10:49:03 +02:00
|
|
|
if is_op classln then
|
2010-09-14 09:39:02 +02:00
|
|
|
cop_of_op_aux classln args
|
2010-06-15 10:49:03 +02:00
|
|
|
else
|
|
|
|
(** The step function takes scalar arguments and its own internal memory
|
2010-06-16 11:32:13 +02:00
|
|
|
holding structure. *)
|
2010-09-10 14:29:13 +02:00
|
|
|
let args = step_fun_call var_env sig_info objn out args in
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Our C expression for the function call. *)
|
2010-06-26 16:53:25 +02:00
|
|
|
Cfun_call (classn ^ "_step", args)
|
2010-06-15 10:49:03 +02:00
|
|
|
in
|
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Act according to the length of our list. Step functions with
|
2011-04-27 14:02:50 +02:00
|
|
|
multiple return values will return a structure, and we care of
|
2010-06-16 11:32:13 +02:00
|
|
|
assigning each field to the corresponding local variable. *)
|
|
|
|
match outvl with
|
|
|
|
| [] -> [Csexpr fun_call]
|
2010-06-30 17:30:24 +02:00
|
|
|
| [outv] when is_op classln ->
|
|
|
|
let ty = assoc_type_lhs outv var_env in
|
2011-04-27 14:02:50 +02:00
|
|
|
create_affect_stm outv fun_call ty
|
2010-06-16 11:32:13 +02:00
|
|
|
| _ ->
|
|
|
|
(* Remove options *)
|
|
|
|
let out_sig = output_names_list sig_info in
|
|
|
|
let create_affect outv out_name =
|
2010-06-30 17:30:24 +02:00
|
|
|
let ty = assoc_type_lhs outv var_env in
|
2010-09-13 15:16:12 +02:00
|
|
|
create_affect_stm outv (Clhs (Cfield (out, local_qn out_name))) ty
|
2010-06-30 17:30:24 +02:00
|
|
|
in
|
|
|
|
(Csexpr fun_call)::(List.flatten (map2 create_affect outvl out_sig))
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** Create the statement dest = c where c = v^n^m... *)
|
|
|
|
let rec create_affect_const var_env dest c =
|
2010-07-09 09:31:12 +02:00
|
|
|
match c.se_desc with
|
2010-10-02 13:17:12 +02:00
|
|
|
| Svar ln ->
|
|
|
|
let se = Static.simplify QualEnv.empty (find_const ln).c_value in
|
|
|
|
create_affect_const var_env dest se
|
2010-07-09 09:31:12 +02:00
|
|
|
| Sarray_power(c, n) ->
|
2010-06-16 11:32:13 +02:00
|
|
|
let x = gen_symbol () in
|
2011-04-18 15:38:42 +02:00
|
|
|
[Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp n,
|
2010-07-19 15:16:14 +02:00
|
|
|
create_affect_const var_env (Carray (dest, Clhs (Cvar x))) c)]
|
|
|
|
| Sarray cl ->
|
|
|
|
let create_affect_idx c (i, affl) =
|
|
|
|
let dest = Carray (dest, Cconst (Ccint i)) in
|
2011-05-03 13:21:27 +02:00
|
|
|
(i - 1, create_affect_const var_env dest c @ affl)
|
|
|
|
in
|
|
|
|
snd (List.fold_right create_affect_idx cl (List.length cl - 1, []))
|
|
|
|
| Srecord f_se_list ->
|
|
|
|
let affect_field affl (f, se) =
|
|
|
|
let dest_f = Cfield (dest, f) in
|
|
|
|
(create_affect_const var_env dest_f se) @ affl
|
|
|
|
in
|
|
|
|
List.fold_left affect_field [] f_se_list
|
2011-03-08 09:22:02 +01:00
|
|
|
| _ -> [Caffect (dest, cexpr_of_static_exp c)]
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
(** [cstm_of_act obj_env mods act] translates the Obj action [act] to a list of
|
|
|
|
C statements, using the association list [obj_env] to map object names to
|
|
|
|
class names. *)
|
2010-06-15 10:49:03 +02:00
|
|
|
let rec cstm_of_act var_env obj_env act =
|
|
|
|
match act with
|
2010-11-04 18:06:11 +01:00
|
|
|
(** Cosmetic : cases on boolean values are converted to if statements. *)
|
2010-09-09 00:35:06 +02:00
|
|
|
| Acase (c, [({name = "true"}, te); ({ name = "false" }, fe)])
|
|
|
|
| Acase (c, [({name = "false"}, fe); ({ name = "true"}, te)]) ->
|
2010-06-15 10:49:03 +02:00
|
|
|
let cc = cexpr_of_exp var_env c in
|
2010-07-09 09:31:12 +02:00
|
|
|
let cte = cstm_of_act_list var_env obj_env te in
|
|
|
|
let cfe = cstm_of_act_list var_env obj_env fe in
|
2010-06-15 10:49:03 +02:00
|
|
|
[Cif (cc, cte, cfe)]
|
2010-11-04 18:06:11 +01:00
|
|
|
| Acase (c, [({name = "true"}, te)]) ->
|
|
|
|
let cc = cexpr_of_exp var_env c in
|
|
|
|
let cte = cstm_of_act_list var_env obj_env te in
|
|
|
|
let cfe = [] in
|
|
|
|
[Cif (cc, cte, cfe)]
|
|
|
|
| Acase (c, [({name = "false"}, fe)]) ->
|
|
|
|
let cc = Cuop ("!", (cexpr_of_exp var_env c)) in
|
|
|
|
let cte = cstm_of_act_list var_env obj_env fe in
|
|
|
|
let cfe = [] in
|
|
|
|
[Cif (cc, cte, cfe)]
|
|
|
|
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2010-06-18 10:55:16 +02:00
|
|
|
(** Translation of case into a C switch statement is simple enough: we
|
|
|
|
just recursively translate obj expressions and statements to
|
|
|
|
corresponding C constructs, and cautiously "shortnamize"
|
|
|
|
constructor names. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Acase (e, cl) ->
|
2010-06-15 10:49:03 +02:00
|
|
|
(** [ccl_of_obccl] translates an Obc clause to a C clause. *)
|
|
|
|
let ccl =
|
2010-06-16 11:32:13 +02:00
|
|
|
List.map
|
2010-09-13 09:37:58 +02:00
|
|
|
(fun (c,act) -> cname_of_qn c,
|
2010-07-09 09:31:12 +02:00
|
|
|
cstm_of_act_list var_env obj_env act) cl in
|
2010-06-15 10:49:03 +02:00
|
|
|
[Cswitch (cexpr_of_exp var_env e, ccl)]
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2011-03-08 09:22:02 +01:00
|
|
|
| Ablock b ->
|
|
|
|
cstm_of_act_list var_env obj_env b
|
|
|
|
|
2010-06-18 10:55:16 +02:00
|
|
|
(** For composition of statements, just recursively apply our
|
|
|
|
translation function on sub-statements. *)
|
2011-03-21 14:30:19 +01:00
|
|
|
| Afor ({ v_ident = x }, i1, i2, act) ->
|
2011-04-18 15:38:42 +02:00
|
|
|
[Cfor(name x, cexpr_of_exp var_env i1,
|
|
|
|
cexpr_of_exp var_env i2, cstm_of_act_list var_env obj_env act)]
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2011-01-11 14:46:28 +01:00
|
|
|
(** Special case for x = 0^n^n...*)
|
|
|
|
| Aassgn (vn, { e_desc = Econst c }) ->
|
|
|
|
let vn = clhs_of_lhs var_env vn in
|
|
|
|
create_affect_const var_env vn c
|
|
|
|
|
|
|
|
(** Purely syntactic translation from an Obc local variable to a C
|
|
|
|
local one, with recursive translation of the rhs expression. *)
|
|
|
|
| Aassgn (vn, e) ->
|
|
|
|
let vn = clhs_of_lhs var_env vn in
|
|
|
|
let ty = assoc_type_lhs vn var_env in
|
|
|
|
let ce = cexpr_of_exp var_env e in
|
|
|
|
create_affect_stm vn ce ty
|
|
|
|
|
2011-04-28 15:20:21 +02:00
|
|
|
(** Our Aop marks an operator invocation that will perform side effects. Just
|
|
|
|
translate to a simple C statement. *)
|
|
|
|
| Aop (op_name, args) ->
|
|
|
|
[Csexpr (cop_of_op var_env op_name args)]
|
|
|
|
|
2010-06-18 10:55:16 +02:00
|
|
|
(** Reinitialization of an object variable, extracting the reset
|
|
|
|
function's name from our environment [obj_env]. *)
|
2010-09-13 13:32:35 +02:00
|
|
|
| Acall (name_list, o, Mreset, args) ->
|
|
|
|
assert_empty name_list;
|
|
|
|
assert_empty args;
|
2010-11-05 15:36:11 +01:00
|
|
|
let on = obj_ref_name o in
|
2010-06-16 11:32:13 +02:00
|
|
|
let obj = assoc_obj on obj_env in
|
2010-09-13 09:37:58 +02:00
|
|
|
let classn = cname_of_qn obj.o_class in
|
2010-07-09 09:31:12 +02:00
|
|
|
(match obj.o_size with
|
2010-09-13 15:16:12 +02:00
|
|
|
| None ->
|
|
|
|
[Csexpr (Cfun_call (classn ^ "_reset",
|
2011-03-08 09:22:02 +01:00
|
|
|
[Caddrof (Cfield (Cderef (Cvar "self"), local_qn (name on)))]))]
|
2010-07-09 09:31:12 +02:00
|
|
|
| Some size ->
|
|
|
|
let x = gen_symbol () in
|
2011-03-08 09:22:02 +01:00
|
|
|
let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in
|
2010-07-09 09:31:12 +02:00
|
|
|
let elt = [Caddrof( Carray(field, Clhs (Cvar x)) )] in
|
2011-04-18 15:38:42 +02:00
|
|
|
[Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp size,
|
2010-07-09 09:31:12 +02:00
|
|
|
[Csexpr (Cfun_call (classn ^ "_reset", elt ))] )]
|
|
|
|
)
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2010-06-18 10:55:16 +02:00
|
|
|
(** Step functions applications can return multiple values, so we use a
|
|
|
|
local structure to hold the results, before allocating to our
|
|
|
|
variables. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Acall (outvl, objn, Mstep, el) ->
|
2010-06-26 16:53:25 +02:00
|
|
|
let args = cexprs_of_exps var_env el in
|
|
|
|
let outvl = clhss_of_lhss var_env outvl in
|
|
|
|
generate_function_call var_env obj_env outvl objn args
|
|
|
|
|
2010-09-13 13:32:35 +02:00
|
|
|
|
2010-07-22 09:36:22 +02:00
|
|
|
and cstm_of_act_list var_env obj_env b =
|
|
|
|
let l = List.map cvar_of_vd b.b_locals in
|
|
|
|
let var_env = l @ var_env in
|
|
|
|
let cstm = List.flatten (List.map (cstm_of_act var_env obj_env) b.b_body) in
|
|
|
|
match l with
|
|
|
|
| [] -> cstm
|
|
|
|
| _ ->
|
|
|
|
[Csblock { var_decls = l; block_body = cstm }]
|
2010-06-16 11:32:13 +02:00
|
|
|
|
|
|
|
(* TODO needed only because of renaming phase *)
|
|
|
|
let global_name = ref "";;
|
|
|
|
|
2010-06-27 14:01:06 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
|
2010-06-27 23:27:54 +02:00
|
|
|
(** {2 step() and reset() functions generation *)
|
2010-06-16 11:32:13 +02:00
|
|
|
|
2010-09-13 15:16:12 +02:00
|
|
|
let qn_append q suffix =
|
|
|
|
{ qual = q.qual; name = q.name ^ suffix }
|
2010-06-16 11:32:13 +02:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** Builds the argument list of step function*)
|
2010-07-16 11:27:41 +02:00
|
|
|
let step_fun_args n md =
|
2010-07-09 09:31:12 +02:00
|
|
|
let args = cvarlist_of_ovarlist md.m_inputs in
|
2010-09-13 15:16:12 +02:00
|
|
|
let out_arg = [("out", Cty_ptr (Cty_id (qn_append n "_out")))] in
|
2010-06-30 17:30:24 +02:00
|
|
|
let context_arg =
|
2011-03-21 14:30:19 +01:00
|
|
|
if is_stateful n then
|
2010-09-13 15:16:12 +02:00
|
|
|
[("self", Cty_ptr (Cty_id (qn_append n "_mem")))]
|
2010-06-30 17:30:24 +02:00
|
|
|
else
|
|
|
|
[]
|
|
|
|
in
|
|
|
|
args @ out_arg @ context_arg
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** [fun_def_of_step_fun name obj_env mods sf] returns a C function definition
|
|
|
|
[name ^ "_out"] corresponding to the Obc step function [sf]. The object name
|
|
|
|
<-> class name mapping [obj_env] is needed to translate internal steps and
|
|
|
|
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
|
2010-06-30 17:30:24 +02:00
|
|
|
field by return value. *)
|
2010-09-13 09:37:58 +02:00
|
|
|
let fun_def_of_step_fun n obj_env mem objs md =
|
|
|
|
let fun_name = (cname_of_qn n) ^ "_step" in
|
2010-06-15 10:49:03 +02:00
|
|
|
(** Its arguments, translating Obc types to C types and adding our internal
|
|
|
|
memory structure. *)
|
2010-09-13 09:37:58 +02:00
|
|
|
let args = step_fun_args n md in
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-30 17:30:24 +02:00
|
|
|
(** Out vars for function calls *)
|
|
|
|
let out_vars =
|
2010-07-07 14:44:18 +02:00
|
|
|
unique
|
2010-09-13 09:37:58 +02:00
|
|
|
(List.map (fun obj -> out_var_name_of_objn (cname_of_qn obj.o_class),
|
2010-09-13 15:16:12 +02:00
|
|
|
Cty_id (qn_append obj.o_class "_out"))
|
2010-07-09 09:31:12 +02:00
|
|
|
(List.filter (fun obj -> not (is_op obj.o_class)) objs)) in
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** The body *)
|
2010-07-09 09:31:12 +02:00
|
|
|
let mems = List.map cvar_of_vd (mem@md.m_outputs) in
|
2010-07-26 17:41:52 +02:00
|
|
|
let var_env = args @ mems @ out_vars in
|
2010-07-09 09:31:12 +02:00
|
|
|
let body = cstm_of_act_list var_env obj_env md.m_body in
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Substitute the return value variables with the corresponding
|
|
|
|
context field*)
|
2010-07-09 09:31:12 +02:00
|
|
|
let map = Csubst.assoc_map_for_fun md in
|
2010-06-30 17:30:24 +02:00
|
|
|
let body = List.map (Csubst.subst_stm map) body in
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
Cfundef {
|
|
|
|
f_name = fun_name;
|
2010-06-30 17:30:24 +02:00
|
|
|
f_retty = Cty_void;
|
2010-06-15 10:49:03 +02:00
|
|
|
f_args = args;
|
|
|
|
f_body = {
|
2010-07-22 17:38:11 +02:00
|
|
|
var_decls = out_vars;
|
2010-07-09 09:31:12 +02:00
|
|
|
block_body = body
|
2010-06-15 10:49:03 +02:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
(** [mem_decl_of_class_def cd] returns a declaration for a C structure holding
|
|
|
|
internal variables and objects of the Obc class definition [cd]. *)
|
|
|
|
let mem_decl_of_class_def cd =
|
|
|
|
(** This one just translates the class name to a struct name following the
|
|
|
|
convention we described above. *)
|
|
|
|
let struct_field_of_obj_dec l od =
|
2011-03-21 14:30:19 +01:00
|
|
|
if is_stateful od.o_class then
|
2010-09-13 15:16:12 +02:00
|
|
|
let ty = Cty_id (qn_append od.o_class "_mem") in
|
2010-07-09 09:31:12 +02:00
|
|
|
let ty = match od.o_size with
|
|
|
|
| Some se -> Cty_arr (int_of_static_exp se, ty)
|
|
|
|
| None -> ty in
|
2011-03-08 09:22:02 +01:00
|
|
|
(name od.o_ident, ty)::l
|
2010-06-15 10:49:03 +02:00
|
|
|
else
|
2010-06-30 17:30:24 +02:00
|
|
|
l
|
2010-06-15 10:49:03 +02:00
|
|
|
in
|
2011-03-21 14:30:19 +01:00
|
|
|
if is_stateful cd.cd_name then (
|
2010-06-30 17:30:24 +02:00
|
|
|
(** Fields corresponding to normal memory variables. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
let mem_fields = List.map cvar_of_vd cd.cd_mems in
|
2010-06-30 17:30:24 +02:00
|
|
|
(** Fields corresponding to object variables. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
let obj_fields = List.fold_left struct_field_of_obj_dec [] cd.cd_objs in
|
2010-09-13 09:37:58 +02:00
|
|
|
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_mem",
|
|
|
|
mem_fields @ obj_fields)]
|
2010-06-30 17:30:24 +02:00
|
|
|
) else
|
|
|
|
[]
|
|
|
|
|
|
|
|
let out_decl_of_class_def cd =
|
2010-07-07 09:58:12 +02:00
|
|
|
(** Fields corresponding to output variables. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
let step_m = find_step_method cd in
|
|
|
|
let out_fields = List.map cvar_of_vd step_m.m_outputs in
|
2010-09-13 09:37:58 +02:00
|
|
|
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_out", out_fields)]
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** [reset_fun_def_of_class_def cd] returns the defintion of the C function
|
|
|
|
tasked to reset the class [cd]. *)
|
|
|
|
let reset_fun_def_of_class_def cd =
|
2011-03-21 14:30:19 +01:00
|
|
|
let body =
|
|
|
|
try
|
|
|
|
let var_env = List.map cvar_of_vd cd.cd_mems in
|
|
|
|
let reset = find_reset_method cd in
|
|
|
|
cstm_of_act_list var_env cd.cd_objs reset.m_body
|
|
|
|
with Not_found -> [] (* TODO C : nicely deal with stateless objects *)
|
|
|
|
in
|
2010-06-15 10:49:03 +02:00
|
|
|
Cfundef {
|
2010-09-13 09:37:58 +02:00
|
|
|
f_name = (cname_of_qn cd.cd_name) ^ "_reset";
|
2010-06-15 10:49:03 +02:00
|
|
|
f_retty = Cty_void;
|
2010-09-13 15:16:12 +02:00
|
|
|
f_args = [("self", Cty_ptr (Cty_id (qn_append cd.cd_name "_mem")))];
|
2010-06-15 10:49:03 +02:00
|
|
|
f_body = {
|
|
|
|
var_decls = [];
|
|
|
|
block_body = body;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2011-03-21 14:30:19 +01:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** [cdecl_and_cfun_of_class_def cd] translates the class definition [cd] to
|
|
|
|
a C program. *)
|
|
|
|
let cdefs_and_cdecls_of_class_def cd =
|
|
|
|
(** We keep the state of our class in a structure, holding both internal
|
|
|
|
variables and the state of other nodes. For a class named ["cname"], the
|
|
|
|
structure will be called ["cname_mem"]. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
let step_m = find_step_method cd in
|
2010-06-15 10:49:03 +02:00
|
|
|
let memory_struct_decl = mem_decl_of_class_def cd in
|
2010-06-30 17:30:24 +02:00
|
|
|
let out_struct_decl = out_decl_of_class_def cd in
|
2010-09-13 09:37:58 +02:00
|
|
|
let step_fun_def = fun_def_of_step_fun cd.cd_name
|
|
|
|
cd.cd_objs cd.cd_mems cd.cd_objs step_m in
|
2010-06-15 10:49:03 +02:00
|
|
|
(** 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
|
2010-07-27 16:27:07 +02:00
|
|
|
let (decls, defs) =
|
2011-03-21 14:30:19 +01:00
|
|
|
if is_stateful cd.cd_name then
|
2010-06-30 17:30:24 +02:00
|
|
|
([res_fun_decl; step_fun_decl], [reset_fun_def; step_fun_def])
|
|
|
|
else
|
|
|
|
([step_fun_decl], [step_fun_def]) in
|
|
|
|
|
2010-07-27 16:27:07 +02:00
|
|
|
memory_struct_decl @ out_struct_decl @ decls,
|
|
|
|
defs
|
2010-06-27 23:27:54 +02:00
|
|
|
|
|
|
|
(** {2 Type translation} *)
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
let decls_of_type_decl otd =
|
2010-09-13 09:37:58 +02:00
|
|
|
let name = cname_of_qn otd.t_name in
|
2010-06-15 10:49:03 +02:00
|
|
|
match otd.t_desc with
|
|
|
|
| Type_abs -> [] (*assert false*)
|
2010-07-26 17:41:52 +02:00
|
|
|
| Type_alias ty -> [Cdecl_typedef (ctype_of_otype ty, name)]
|
2010-06-15 10:49:03 +02:00
|
|
|
| Type_enum nl ->
|
2010-06-16 11:32:13 +02:00
|
|
|
let name = !global_name ^ "_" ^ name in
|
2010-09-13 13:44:26 +02:00
|
|
|
[Cdecl_enum (name, List.map cname_of_qn nl);
|
2010-06-15 10:49:03 +02:00
|
|
|
Cdecl_function (name ^ "_of_string",
|
2010-09-13 15:16:12 +02:00
|
|
|
Cty_id otd.t_name,
|
2010-06-15 10:49:03 +02:00
|
|
|
[("s", Cty_ptr Cty_char)]);
|
|
|
|
Cdecl_function ("string_of_" ^ name,
|
|
|
|
Cty_ptr Cty_char,
|
2010-09-13 15:16:12 +02:00
|
|
|
[("x", Cty_id otd.t_name); ("buf", Cty_ptr Cty_char)])]
|
2010-06-15 10:49:03 +02:00
|
|
|
| Type_struct fl ->
|
2010-09-13 09:37:58 +02:00
|
|
|
let decls = List.map (fun f -> cname_of_qn f.Signature.f_name,
|
2010-07-13 14:03:39 +02:00
|
|
|
ctype_of_otype f.Signature.f_type) fl in
|
2010-09-13 09:37:58 +02:00
|
|
|
[Cdecl_struct (name, decls)];;
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** Translates an Obc type declaration to its C counterpart. *)
|
|
|
|
let cdefs_and_cdecls_of_type_decl otd =
|
2010-09-13 09:37:58 +02:00
|
|
|
let name = cname_of_qn otd.t_name in
|
2010-06-15 10:49:03 +02:00
|
|
|
match otd.t_desc with
|
|
|
|
| Type_abs -> [], [] (*assert false*)
|
2010-09-13 15:16:12 +02:00
|
|
|
| Type_alias ty ->
|
|
|
|
[], [Cdecl_typedef (ctype_of_otype ty, name)]
|
2010-06-15 10:49:03 +02:00
|
|
|
| Type_enum nl ->
|
|
|
|
let of_string_fun = Cfundef
|
|
|
|
{ f_name = name ^ "_of_string";
|
2010-09-13 15:16:12 +02:00
|
|
|
f_retty = Cty_id otd.t_name;
|
2010-06-15 10:49:03 +02:00
|
|
|
f_args = [("s", Cty_ptr Cty_char)];
|
|
|
|
f_body =
|
|
|
|
{ var_decls = [];
|
|
|
|
block_body =
|
|
|
|
let gen_if t =
|
2010-09-13 13:44:26 +02:00
|
|
|
let t = cname_of_qn t in
|
2010-06-15 10:49:03 +02:00
|
|
|
let funcall = Cfun_call ("strcmp", [Clhs (Cvar "s");
|
|
|
|
Cconst (Cstrlit t)]) in
|
|
|
|
let cond = Cbop ("==", funcall, Cconst (Ccint 0)) in
|
|
|
|
Cif (cond, [Creturn (Cconst (Ctag t))], []) in
|
|
|
|
map gen_if nl; }
|
|
|
|
}
|
|
|
|
and to_string_fun = Cfundef
|
|
|
|
{ f_name = "string_of_" ^ name;
|
|
|
|
f_retty = Cty_ptr Cty_char;
|
2010-09-13 15:16:12 +02:00
|
|
|
f_args = [("x", Cty_id otd.t_name); ("buf", Cty_ptr Cty_char)];
|
2010-06-15 10:49:03 +02:00
|
|
|
f_body =
|
|
|
|
{ var_decls = [];
|
|
|
|
block_body =
|
|
|
|
let gen_clause t =
|
2010-09-13 13:44:26 +02:00
|
|
|
let t = cname_of_qn t in
|
2010-06-15 10:49:03 +02:00
|
|
|
let fun_call =
|
|
|
|
Cfun_call ("strcpy", [Clhs (Cvar "buf");
|
|
|
|
Cconst (Cstrlit t)]) in
|
|
|
|
(t, [Csexpr fun_call]) in
|
|
|
|
[Cswitch (Clhs (Cvar "x"), map gen_clause nl);
|
|
|
|
Creturn (Clhs (Cvar "buf"))]; }
|
|
|
|
} in
|
|
|
|
([of_string_fun; to_string_fun],
|
2010-09-13 13:44:26 +02:00
|
|
|
[Cdecl_enum (name, List.map cname_of_qn nl);
|
|
|
|
cdecl_of_cfundef of_string_fun;
|
2010-06-15 10:49:03 +02:00
|
|
|
cdecl_of_cfundef to_string_fun])
|
|
|
|
| Type_struct fl ->
|
2010-09-13 09:37:58 +02:00
|
|
|
let decls = List.map (fun f -> cname_of_qn f.Signature.f_name,
|
2010-07-13 14:03:39 +02:00
|
|
|
ctype_of_otype f.Signature.f_type) fl in
|
2010-09-13 09:37:58 +02:00
|
|
|
let decl = Cdecl_struct (name, decls) in
|
2010-06-16 11:32:13 +02:00
|
|
|
([], [decl])
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** [cfile_list_of_oprog oprog] translates the Obc program [oprog] to a list of
|
|
|
|
C source and header files. *)
|
2010-07-27 16:27:07 +02:00
|
|
|
let cfile_list_of_oprog_ty_decls name oprog =
|
2011-04-19 09:23:52 +02:00
|
|
|
let types = Obc_utils.program_types oprog in
|
|
|
|
let cdefs_and_cdecls = List.map cdefs_and_cdecls_of_type_decl types in
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-09-13 15:16:12 +02:00
|
|
|
let (cty_defs, cty_decls) = List.split cdefs_and_cdecls in
|
2010-06-15 10:49:03 +02:00
|
|
|
let filename_types = name ^ "_types" in
|
|
|
|
let types_h = (filename_types ^ ".h",
|
2011-04-28 15:20:21 +02:00
|
|
|
Cheader (["stdbool"; "assert"], List.concat cty_decls)) in
|
2010-06-15 10:49:03 +02:00
|
|
|
let types_c = (filename_types ^ ".c", Csource (concat cty_defs)) in
|
2010-07-27 16:27:07 +02:00
|
|
|
|
|
|
|
filename_types, [types_h; types_c]
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
let global_file_header name prog =
|
2011-03-08 09:22:02 +01:00
|
|
|
let dependencies = ModulSet.elements (Obc_utils.Deps.deps_program prog) in
|
2011-05-09 09:50:18 +02:00
|
|
|
let dependencies = List.map (fun m -> String.uncapitalize (modul_to_string m)) dependencies in
|
2010-07-27 16:27:07 +02:00
|
|
|
|
2011-04-19 09:23:52 +02:00
|
|
|
let classes = program_classes prog in
|
2010-07-27 16:27:07 +02:00
|
|
|
let (decls, defs) =
|
2011-04-19 09:23:52 +02:00
|
|
|
List.split (List.map cdefs_and_cdecls_of_class_def classes) in
|
2010-07-27 16:27:07 +02:00
|
|
|
let decls = List.concat decls
|
|
|
|
and defs = List.concat defs in
|
|
|
|
|
|
|
|
let (ty_fname, ty_files) = cfile_list_of_oprog_ty_decls name prog in
|
|
|
|
|
|
|
|
let header =
|
|
|
|
(name ^ ".h", Cheader (ty_fname :: dependencies, decls))
|
|
|
|
and source =
|
|
|
|
(name ^ ".c", Csource defs) in
|
|
|
|
[header; source] @ ty_files
|