1119 lines
39 KiB
OCaml
1119 lines
39 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Heptagon *)
|
|
(* *)
|
|
(* Gwenael Delaval, LIG/INRIA, UJF *)
|
|
(* Leonard Gerard, Parkas, ENS *)
|
|
(* Adrien Guatto, Parkas, ENS *)
|
|
(* Cedric Pasteur, Parkas, ENS *)
|
|
(* Marc Pouzet, Parkas, ENS *)
|
|
(* *)
|
|
(* Copyright 2012 ENS, INRIA, UJF *)
|
|
(* *)
|
|
(* This file is part of the Heptagon compiler. *)
|
|
(* *)
|
|
(* Heptagon is free software: you can redistribute it and/or modify it *)
|
|
(* under the terms of the GNU General Public License as published by *)
|
|
(* the Free Software Foundation, either version 3 of the License, or *)
|
|
(* (at your option) any later version. *)
|
|
(* *)
|
|
(* Heptagon is distributed in the hope that it will be useful, *)
|
|
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
|
|
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
|
|
(* GNU General Public License for more details. *)
|
|
(* *)
|
|
(* You should have received a copy of the GNU General Public License *)
|
|
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
open List
|
|
open Misc
|
|
open Names
|
|
open Idents
|
|
open Obc
|
|
open Obc_utils
|
|
open Types
|
|
open Async_avr
|
|
|
|
open Modules
|
|
open Signature
|
|
open C
|
|
open Location
|
|
open Format
|
|
|
|
module Error =
|
|
struct
|
|
type error =
|
|
| Evar of string
|
|
| Enode of string
|
|
| Eno_unnamed_output
|
|
| Ederef_not_pointer
|
|
| Estatic_exp_compute_failed
|
|
| Eunknown_method of string
|
|
|
|
let message loc kind = (match kind with
|
|
| Evar name ->
|
|
eprintf "%aCode generation : The variable name '%s' is unbound.@."
|
|
print_location loc name
|
|
| Enode name ->
|
|
eprintf "%aCode generation : The node name '%s' is unbound.@."
|
|
print_location loc name
|
|
| Eno_unnamed_output ->
|
|
eprintf "%aCode generation : Unnamed outputs are not supported.@."
|
|
print_location loc
|
|
| Ederef_not_pointer ->
|
|
eprintf "%aCode generation : Trying to deference a non pointer type.@."
|
|
print_location loc
|
|
| Estatic_exp_compute_failed ->
|
|
eprintf "%aCode generation : Computation of the value of the static \
|
|
expression failed.@."
|
|
print_location loc
|
|
| Eunknown_method s ->
|
|
eprintf "%aCode generation : Methods other than step and \
|
|
reset are not supported (found '%s').@."
|
|
print_location loc
|
|
s);
|
|
raise Errors.Error
|
|
end
|
|
|
|
type vars_rewriter =
|
|
{ vr_vars : IdentSet.t;
|
|
vr_rewrite : ident -> cexpr }
|
|
|
|
let vr_match vr var = IdentSet.mem var vr.vr_vars
|
|
|
|
let vr_direct vars =
|
|
{ vr_vars = vars;
|
|
vr_rewrite = fun var -> Cvar (name var) }
|
|
|
|
let vr_field st_expr vars =
|
|
{ vr_vars = vars;
|
|
vr_rewrite = fun var -> Cfield (st_expr, local_qn (name var)) }
|
|
|
|
let vr_rewrite vr var =
|
|
if vr_match vr var then
|
|
vr.vr_rewrite var
|
|
else
|
|
Cvar (name var)
|
|
|
|
let vr_compose a b =
|
|
let rewrite var =
|
|
let vr = if vr_match a var then a else b in
|
|
vr_rewrite vr var
|
|
in
|
|
{ vr_rewrite = rewrite;
|
|
vr_vars = IdentSet.union a.vr_vars b.vr_vars }
|
|
|
|
let ident_set_of_var_decs vds =
|
|
List.fold_left
|
|
(fun set vd -> IdentSet.add vd.v_ident set)
|
|
IdentSet.empty
|
|
vds
|
|
|
|
let struct_name ty =
|
|
match ty with
|
|
| Cty_id n -> n
|
|
| _ -> assert false
|
|
|
|
let int_of_static_exp se =
|
|
Static.int_of_static_exp QualEnv.empty se
|
|
|
|
|
|
let output_names_list sig_info =
|
|
let remove_option ad = match ad.a_name with
|
|
| Some n -> n
|
|
| None -> Error.message no_location Error.Eno_unnamed_output
|
|
in
|
|
let outputs = List.filter
|
|
(fun ad -> not (Linearity.is_linear ad.a_linearity)) sig_info.node_outputs in
|
|
List.map remove_option outputs
|
|
|
|
let is_stateful n =
|
|
try
|
|
let sig_info = find_value n in
|
|
sig_info.node_stateful
|
|
with
|
|
Not_found -> Error.message no_location (Error.Enode (fullname n))
|
|
|
|
(******************************)
|
|
|
|
(** {2 Translation from Obc to C using our AST.} *)
|
|
|
|
(** [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
|
|
each function (i.e., not opened by an "open" declaration).
|
|
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
|
|
| 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 id
|
|
| Tarray(ty, n) -> Cty_arr(int_of_static_exp n, ctype_of_otype ty)
|
|
| Tprod _ -> assert false
|
|
| Tinvalid -> assert false
|
|
|
|
let (has_native_c_op, native_c_op_of) =
|
|
let assl =
|
|
[
|
|
(["~-"; "~-."], "-");
|
|
(["~~"], "~");
|
|
(["not"], "!");
|
|
|
|
(["="], "==");
|
|
(["<>"], "!=");
|
|
(["&"], "&&");
|
|
(["or"], "||");
|
|
(["xor"], "^");
|
|
|
|
(["+"; "+."], "+");
|
|
(["-"; "-."], "-");
|
|
(["*"; "*."], "*");
|
|
(["/"; "/."], "/");
|
|
(["%"], "%");
|
|
|
|
(["<"; "<."], "<");
|
|
(["<="; "<="], "<=");
|
|
([">"; ">."], ">");
|
|
([">="; ">=."], ">=");
|
|
|
|
([">>>"], ">>");
|
|
(["<<<"], "<<");
|
|
(["&&&"], "&");
|
|
(["|||"], "|");
|
|
]
|
|
in
|
|
let ht = Hashtbl.create (List.length assl) in
|
|
List.iter (fun (xl, y) -> List.iter (fun x -> Hashtbl.add ht x y) xl) assl;
|
|
Hashtbl.mem ht, Hashtbl.find ht
|
|
|
|
let cformat_of_format s =
|
|
let aux m = match m with
|
|
| "b" -> "d" (*no booleans in C*)
|
|
| _ -> m
|
|
in
|
|
match s with
|
|
| Cconst (Cstrlit s) -> Cconst (Cstrlit (Printf_parser.tr_format aux s))
|
|
| _ -> assert false
|
|
|
|
(** Translates an Obc var_dec to a tuple (name, cty). *)
|
|
let cvar_of_vd vd =
|
|
name vd.v_ident, ctype_of_otype vd.v_type
|
|
|
|
(** Returns the type of a pointer to a type, except for
|
|
types which are already pointers. *)
|
|
let pointer_type ty cty =
|
|
match Modules.unalias_type ty with
|
|
| Tarray _ -> cty
|
|
| _ -> Cty_ptr cty
|
|
|
|
(** Returns the expression to use e as an argument of
|
|
a function expecting a pointer as argument. *)
|
|
let address_of ty e =
|
|
match Modules.unalias_type ty with
|
|
| Tarray _ -> e
|
|
| _ -> Caddrof e
|
|
|
|
let inputlist_of_ovarlist vl =
|
|
let cvar_of_ovar vd =
|
|
let ty = ctype_of_otype vd.v_type in
|
|
let ty = if vd.v_mutable then pointer_type vd.v_type ty else ty in
|
|
name vd.v_ident, ty
|
|
in
|
|
List.map cvar_of_ovar vl
|
|
|
|
(** @return the unaliased version of a type. *)
|
|
let rec unalias_ctype cty = match cty with
|
|
| Cty_id ty_name ->
|
|
(try match find_type ty_name with
|
|
| Talias ty -> unalias_ctype (ctype_of_otype ty)
|
|
| _ -> Cty_id ty_name
|
|
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
|
|
|
|
(** Returns the type associated with the name [n]
|
|
in the environnement [var_env] (which is an association list
|
|
mapping strings to cty). *)
|
|
and assoc_type n var_env =
|
|
try unalias_ctype (List.assoc n var_env)
|
|
with Not_found -> Error.message no_location (Error.Evar n)
|
|
|
|
(** 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
|
|
| CLvar x -> unalias_ctype (assoc_type x var_env)
|
|
| CLarray (lhs, _) ->
|
|
let ty = assoc_type_lhs lhs var_env in
|
|
array_base_ctype ty [1]
|
|
| CLderef lhs ->
|
|
(match assoc_type_lhs lhs var_env with
|
|
| Cty_ptr ty -> ty
|
|
| _ -> Error.message no_location Error.Ederef_not_pointer)
|
|
| CLfield(CLderef (CLvar "self"), { name = x }) -> assoc_type x var_env
|
|
(* TODO(Arduino): it's probably not necessary, but we could choose to
|
|
use assoc_type depending on the async state of the node *)
|
|
| CLfield(CLderef (CLvar "_out"), { name = x }) -> assoc_type x var_env
|
|
| CLfield(CLvar "_local_out", { name = x }) -> assoc_type x var_env
|
|
| CLfield(x, f) ->
|
|
let ty = assoc_type_lhs x var_env in
|
|
let n = struct_name ty in
|
|
let fields = find_struct n in
|
|
ctype_of_otype (field_assoc f fields)
|
|
|
|
(** Creates the statement a = [e_1, e_2, ..], which gives a list
|
|
a[i] = e_i.*)
|
|
let rec create_affect_lit dest l ty =
|
|
let rec _create_affect_lit dest i = function
|
|
| [] -> []
|
|
| v::l ->
|
|
let stm = create_affect_stm (CLarray (dest, Cconst (Ccint i))) v ty in
|
|
stm@(_create_affect_lit dest (i+1) l)
|
|
in
|
|
_create_affect_lit dest 0 l
|
|
|
|
(** Creates the expression dest <- src (copying arrays if necessary). *)
|
|
and create_affect_stm dest src ty =
|
|
match unalias_ctype ty with
|
|
| Cty_arr (n, bty) ->
|
|
(match src with
|
|
| Carraylit l -> create_affect_lit dest l bty
|
|
| src ->
|
|
let x = gen_symbol () in
|
|
[Cfor(x,
|
|
Cconst (Ccint 0), Cconst (Ccint n),
|
|
create_affect_stm
|
|
(CLarray (dest, Cvar x))
|
|
(Carray (src, Cvar x)) bty)]
|
|
)
|
|
| Cty_id ln ->
|
|
(match src with
|
|
| Cstructlit (_, ce_list) ->
|
|
let create_affect { Signature.f_name = f_name;
|
|
Signature.f_type = f_type; } e stm_list =
|
|
let cty = ctype_of_otype f_type in
|
|
create_affect_stm (CLfield (dest, f_name)) e cty @ stm_list in
|
|
List.fold_right2 create_affect (find_struct ln) ce_list []
|
|
| _ -> [Caffect (dest, src)])
|
|
| _ -> [Caffect (dest, src)]
|
|
|
|
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"))
|
|
| Sstring s -> Cconst (Cstrlit s)
|
|
| Sfield _ -> assert false
|
|
| Sconstructor c -> Cconst (Ctag (cname_of_qn c))
|
|
| Sarray sl -> Carraylit (List.map cexpr_of_static_exp sl)
|
|
| Srecord fl ->
|
|
let ty_name =
|
|
match Modules.unalias_type se.se_ty with
|
|
| Types.Tid n -> n
|
|
| _ -> assert false
|
|
in
|
|
let cexps_assoc = List.rev_map (fun (f, e) -> f, cexpr_of_static_exp e) fl in
|
|
cexpr_of_struct ty_name cexps_assoc
|
|
| Sarray_power(c,n_list) ->
|
|
(List.fold_left (fun cc n -> Carraylit (repeat_list cc (int_of_static_exp n)))
|
|
(cexpr_of_static_exp c) n_list)
|
|
| Svar ln ->
|
|
if !Compiler_options.unroll_loops && se.se_ty = Initial.tint
|
|
then cexpr_of_static_exp
|
|
(Static.simplify QualEnv.empty (find_const ln).Signature.c_value)
|
|
else Cvar (cname_of_qn ln)
|
|
| Sop _ ->
|
|
let se' = Static.simplify QualEnv.empty se in
|
|
if se = se' then
|
|
Error.message se.se_loc Error.Estatic_exp_compute_failed
|
|
else
|
|
cexpr_of_static_exp se'
|
|
| Stuple _ -> Misc.internal_error "cgen: static tuple"
|
|
|
|
(** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *)
|
|
and cexpr_of_exp vr var_env exp =
|
|
match exp.e_desc with
|
|
| Eextvalue w -> cexpr_of_ext_value vr var_env w
|
|
(* Operators *)
|
|
| Eop(op, exps) -> cop_of_op vr var_env op exps
|
|
(* Structure literals. *)
|
|
| Estruct (tyn, fl) ->
|
|
let cexpr = cexpr_of_exp vr var_env in
|
|
let cexps_assoc = List.rev_map (fun (f, e) -> f, cexpr e) fl in
|
|
cexpr_of_struct tyn cexps_assoc
|
|
| Earray e_list ->
|
|
Carraylit (cexprs_of_exps vr var_env e_list)
|
|
|
|
and cexpr_of_struct tyn cexps_assoc =
|
|
let cexps = List.fold_left
|
|
(fun cexps { Signature.f_name = f } -> List.assoc f cexps_assoc :: cexps)
|
|
[] (find_struct tyn) in
|
|
(* Reverse `cexps' here because of the previous use of `List.fold_left'. *)
|
|
Cstructlit (cname_of_qn tyn, List.rev cexps)
|
|
|
|
and cexprs_of_exps vr var_env exps =
|
|
List.map (cexpr_of_exp vr var_env) exps
|
|
|
|
and cop_of_op_aux op_name cexps = match op_name with
|
|
| { qual = Pervasives; name = op } ->
|
|
begin match op,cexps with
|
|
| "=>", [el;er] ->
|
|
Cbop ("||", (Cuop("!",el)), er)
|
|
| uop, [e] when has_native_c_op op ->
|
|
Cuop (native_c_op_of uop, e)
|
|
| bop, [el;er] when has_native_c_op op ->
|
|
Cbop (native_c_op_of bop, el, er)
|
|
| _ ->
|
|
Cfun_call (op, cexps)
|
|
end
|
|
| { qual = Module "Iostream"; name = "printf" } ->
|
|
let s, args = assert_1min cexps in
|
|
let s = cformat_of_format s in
|
|
Cfun_call("printf", s::args)
|
|
| { qual = Module "Iostream"; name = "fprintf" } ->
|
|
let file, s, args = assert_2min cexps in
|
|
let s = cformat_of_format s in
|
|
Cfun_call("fprintf", file::s::args)
|
|
| { name = op } -> Cfun_call(op,cexps)
|
|
|
|
and cop_of_op vr var_env op_name exps =
|
|
let cexps = cexprs_of_exps vr var_env exps in
|
|
cop_of_op_aux op_name cexps
|
|
|
|
and clhs_of_pattern vr var_env l = match l.pat_desc with
|
|
(* Each Obc variable corresponds to a real local C variable. *)
|
|
| Lvar v ->
|
|
let n = name v in
|
|
let n_lhs = clhs_of_cexpr (vr_rewrite vr v) in
|
|
if List.mem_assoc n var_env then
|
|
let ty = assoc_type n var_env in
|
|
(match ty with
|
|
| Cty_ptr _ -> CLderef n_lhs
|
|
| _ -> n_lhs
|
|
)
|
|
else
|
|
n_lhs
|
|
(* Dereference our [self] struct holding the node's memory. *)
|
|
| Lmem v -> CLfield (CLderef (CLvar "self"), local_qn (name v))
|
|
(* Field access. /!\ Indexed Obj expression should be a valid lhs! *)
|
|
| Lfield (l, fn) -> CLfield(clhs_of_pattern vr var_env l, fn)
|
|
| Larray (l, idx) ->
|
|
CLarray(clhs_of_pattern vr var_env l,
|
|
cexpr_of_exp vr var_env idx)
|
|
|
|
and clhs_list_of_pattern_list vr var_env lhss =
|
|
List.map (clhs_of_pattern vr var_env) lhss
|
|
|
|
and cexpr_of_pattern vr var_env l = match l.pat_desc with
|
|
(* Each Obc variable corresponds to a real local C variable. *)
|
|
| Lvar v ->
|
|
let n = name v in
|
|
let n_lhs = vr_rewrite vr v in
|
|
if List.mem_assoc n var_env then
|
|
let ty = assoc_type n var_env in
|
|
(match ty with
|
|
| Cty_ptr _ -> Cderef n_lhs
|
|
| _ -> n_lhs
|
|
)
|
|
else
|
|
n_lhs
|
|
(* Dereference our [self] struct holding the node's memory. *)
|
|
| Lmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v))
|
|
(* Field access. /!\ Indexed Obj expression should be a valid lhs! *)
|
|
| Lfield (l, fn) -> Cfield(cexpr_of_pattern vr var_env l, fn)
|
|
| Larray (l, idx) ->
|
|
Carray(cexpr_of_pattern vr var_env l,
|
|
cexpr_of_exp vr var_env idx)
|
|
|
|
and cexpr_of_ext_value vr var_env w = match w.w_desc with
|
|
| Wconst c -> cexpr_of_static_exp c
|
|
(* Each Obc variable corresponds to a plain local C variable. *)
|
|
| Wvar v ->
|
|
let n = name v in
|
|
let n_lhs = vr_rewrite vr v in
|
|
if List.mem_assoc n var_env then
|
|
let ty = assoc_type n var_env in
|
|
(match ty with
|
|
| Cty_ptr _ -> Cderef n_lhs
|
|
| _ -> n_lhs)
|
|
else
|
|
n_lhs
|
|
(* Dereference our [self] struct holding the node's memory. *)
|
|
| Wmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v))
|
|
(* Field access. /!\ Indexed Obj expression should be a valid lhs! *)
|
|
| Wfield (l, fn) -> Cfield(cexpr_of_ext_value vr var_env l, fn)
|
|
| Warray (l, idx) ->
|
|
Carray(cexpr_of_ext_value vr var_env l,
|
|
cexpr_of_exp vr var_env idx)
|
|
|
|
let rec assoc_obj instance obj_env =
|
|
match obj_env with
|
|
| [] -> raise Not_found
|
|
| od :: t ->
|
|
if od.o_ident = instance
|
|
then od
|
|
else assoc_obj instance t
|
|
|
|
let assoc_cn instance obj_env =
|
|
(assoc_obj (obj_ref_name instance) obj_env).o_class
|
|
|
|
let is_op = function
|
|
| { qual = Pervasives; name = _ } -> true
|
|
| _ -> false
|
|
|
|
let out_var_name_of_objn o =
|
|
o ^"_out_st"
|
|
|
|
(** 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.*)
|
|
let step_fun_call vr var_env sig_info objn out args async =
|
|
let rec add_targeting l ads = match l, ads with
|
|
| [], [] -> []
|
|
| e::l, ad::ads ->
|
|
(*this arg is targeted, use a pointer*)
|
|
let e = if Linearity.is_linear ad.a_linearity then address_of ad.a_type e else e in
|
|
e::(add_targeting l ads)
|
|
| _, _ -> assert false
|
|
in
|
|
let args = (add_targeting args sig_info.node_inputs) in
|
|
if sig_info.node_stateful then (
|
|
let mem =
|
|
(match objn with
|
|
| Oobj o -> Cfield (Cderef (Cvar "self"), local_qn (name o))
|
|
| Oarray (o, l) ->
|
|
let f = Cfield (Cderef (Cvar "self"), local_qn (name o)) in
|
|
let rec mk_idx pl = match pl with
|
|
| [] -> f
|
|
| p::pl ->
|
|
Carray (mk_idx pl, cexpr_of_pattern vr var_env p)
|
|
in
|
|
mk_idx l
|
|
) in
|
|
match async with
|
|
| Some async -> args @ [Caddrof out; Caddrof async]
|
|
| None -> args @ [Caddrof out; Caddrof mem]
|
|
) else
|
|
match async with
|
|
| Some async -> args @ [Caddrof out; Caddrof async]
|
|
| None -> args @ [Caddrof out]
|
|
|
|
let async_global_var_name od = "g_async__" ^ (name od.o_ident)
|
|
|
|
(** Generate the statement to call [objn].
|
|
[outvl] is a list of lhs where to put the results.
|
|
[args] is the list of expressions to use as arguments.
|
|
[mem] is the lhs where is stored the node's context.*)
|
|
let generate_function_call vr var_env obj_env outvl objn args =
|
|
(* Class name for the object to step. *)
|
|
let classln = assoc_cn objn obj_env 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
|
|
let od = assoc_obj (obj_ref_name objn) obj_env in
|
|
|
|
let fun_call =
|
|
if is_op classln then
|
|
cop_of_op_aux classln args
|
|
else
|
|
let async = match od.o_ack with
|
|
| Some _ -> Some (Cvar (async_global_var_name od))
|
|
| None -> None
|
|
in
|
|
(* The step function takes scalar arguments and its own internal
|
|
memory holding structure. *)
|
|
let args =
|
|
step_fun_call vr var_env sig_info objn out args async
|
|
in
|
|
(* Our C expression for the function call. *)
|
|
let suffix = match od.o_ack with
|
|
| Some _ -> "_step_async_stub"
|
|
| None -> "_step"
|
|
in
|
|
Cfun_call (classn ^ suffix, args)
|
|
in
|
|
|
|
(* Act according to the length of our list. Step functions with
|
|
multiple return values will return a structure, and we care of
|
|
assigning each field to the corresponding local variable. *)
|
|
match outvl with
|
|
| [] -> [Csexpr fun_call]
|
|
| [outv] when is_op classln ->
|
|
let ty = assoc_type_lhs outv var_env in
|
|
create_affect_stm outv fun_call ty
|
|
| _ ->
|
|
(* Remove options *)
|
|
let out_sig = output_names_list sig_info in
|
|
let create_affect outv out_name =
|
|
let ty = assoc_type_lhs outv var_env in
|
|
create_affect_stm outv (Cfield (out, local_qn out_name)) ty
|
|
in
|
|
(Csexpr fun_call) :: (List.flatten (map2 create_affect outvl out_sig))
|
|
|
|
(** Create the statement dest = c where c = v^n^m... *)
|
|
let rec create_affect_const var_env (dest : clhs) c =
|
|
match c.se_desc with
|
|
| Svar ln ->
|
|
let se = Static.simplify QualEnv.empty (find_const ln).Signature.c_value in
|
|
create_affect_const var_env dest se
|
|
| Sarray_power(c, n_list) ->
|
|
let rec make_loop power_list replace = match power_list with
|
|
| [] -> dest, replace
|
|
| p :: power_list ->
|
|
let x = gen_symbol () in
|
|
let e, replace =
|
|
make_loop power_list
|
|
(fun y -> [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp p, replace y)]) in
|
|
let e = (CLarray (e, Cvar x)) in
|
|
e, replace
|
|
in
|
|
let e, b = make_loop n_list (fun y -> y) in
|
|
b (create_affect_const var_env e c)
|
|
| Sarray cl ->
|
|
let create_affect_idx c (i, affl) =
|
|
let dest = CLarray (dest, Cconst (Ccint i)) in
|
|
(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 = CLfield (dest, f) in
|
|
(create_affect_const var_env dest_f se) @ affl
|
|
in
|
|
List.fold_left affect_field [] f_se_list
|
|
| _ -> [Caffect (dest, cexpr_of_static_exp c)]
|
|
|
|
(** [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. *)
|
|
let rec cstm_of_act vr var_env obj_env act =
|
|
match act with
|
|
(* Cosmetic : cases on boolean values are converted to if statements. *)
|
|
| Acase (c, [({name = "true"}, te); ({ name = "false" }, fe)])
|
|
| Acase (c, [({name = "false"}, fe); ({ name = "true"}, te)]) ->
|
|
let cc = cexpr_of_exp vr var_env c in
|
|
let cte = cstm_of_act_list vr var_env obj_env te in
|
|
let cfe = cstm_of_act_list vr var_env obj_env fe in
|
|
[Cif (cc, cte, cfe)]
|
|
| Acase (c, [({name = "true"}, te)]) ->
|
|
let cc = cexpr_of_exp vr var_env c in
|
|
let cte = cstm_of_act_list vr var_env obj_env te in
|
|
let cfe = [] in
|
|
[Cif (cc, cte, cfe)]
|
|
| Acase (c, [({name = "false"}, fe)]) ->
|
|
let cc = Cuop ("!", (cexpr_of_exp vr var_env c)) in
|
|
let cte = cstm_of_act_list vr var_env obj_env fe in
|
|
let cfe = [] in
|
|
[Cif (cc, cte, cfe)]
|
|
|
|
|
|
(* 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. *)
|
|
| Acase (e, cl) ->
|
|
(* [ccl_of_obccl] translates an Obc clause to a C clause. *)
|
|
let ccl =
|
|
List.map
|
|
(fun (c,act) -> cname_of_qn c,
|
|
cstm_of_act_list vr var_env obj_env act) cl in
|
|
[Cswitch (cexpr_of_exp vr var_env e, ccl)]
|
|
|
|
| Ablock b ->
|
|
cstm_of_act_list vr var_env obj_env b
|
|
|
|
(* For composition of statements, just recursively apply our
|
|
translation function on sub-statements. *)
|
|
| Afor ({ v_ident = x }, i1, i2, act) ->
|
|
[Cfor(name x, cexpr_of_exp vr var_env i1,
|
|
cexpr_of_exp vr var_env i2,
|
|
cstm_of_act_list vr var_env obj_env act)]
|
|
|
|
(* Translate constant assignment *)
|
|
| Aassgn (vn, { e_desc = Eextvalue { w_desc = Wconst c }; }) ->
|
|
let vn = clhs_of_pattern vr 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_pattern vr var_env vn in
|
|
let ty = assoc_type_lhs vn var_env in
|
|
let ce = cexpr_of_exp vr var_env e in
|
|
create_affect_stm vn ce ty
|
|
|
|
(* 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 vr var_env op_name args)]
|
|
|
|
(* Reinitialization of an object variable, extracting the reset
|
|
function's name from our environment [obj_env]. *)
|
|
| Acall (name_list, o, Mreset, args) ->
|
|
assert_empty name_list;
|
|
assert_empty args;
|
|
let on = obj_ref_name o in
|
|
let obj = assoc_obj on obj_env in
|
|
let classn = cname_of_qn obj.o_class in
|
|
let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in
|
|
(match o with
|
|
| Oobj _ ->
|
|
[Csexpr (Cfun_call (classn ^ "_reset", [Caddrof field]))]
|
|
| Oarray (_, pl) ->
|
|
let rec mk_loop pl field = match pl with
|
|
| [] ->
|
|
[Csexpr (Cfun_call (classn ^ "_reset", [Caddrof field]))]
|
|
| p::pl ->
|
|
mk_loop pl
|
|
(Carray (field, cexpr_of_pattern vr var_env p))
|
|
in
|
|
mk_loop pl field
|
|
)
|
|
|
|
(* Step functions applications can return multiple values, so we use a
|
|
local structure to hold the results, before allocating to our
|
|
variables. *)
|
|
| Acall (outvl, objn, Mstep, el) ->
|
|
let args = cexprs_of_exps vr var_env el in
|
|
let outvl = clhs_list_of_pattern_list vr var_env outvl in
|
|
generate_function_call vr var_env obj_env outvl objn args
|
|
|
|
|
|
and cstm_of_act_list vr 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 vr var_env obj_env) b.b_body)
|
|
in
|
|
match l with
|
|
| [] -> cstm
|
|
| _ ->
|
|
[Csblock { var_decls = l; block_body = cstm }]
|
|
|
|
(* TODO needed only because of renaming phase *)
|
|
let global_name = ref "";;
|
|
|
|
|
|
|
|
(** {2 step() and reset() functions generation} *)
|
|
|
|
let qn_append q suffix =
|
|
{ qual = q.qual; name = q.name ^ suffix }
|
|
|
|
(** Builds the argument list of step function*)
|
|
let step_fun_args n md add_mem =
|
|
let args = inputlist_of_ovarlist md.m_inputs in
|
|
let out_arg = [("_out", Cty_ptr (Cty_id (qn_append n "_out")))] in
|
|
let context_arg =
|
|
if is_stateful n && add_mem then
|
|
[("self", Cty_ptr (Cty_id (qn_append n "_mem")))]
|
|
else
|
|
[]
|
|
in
|
|
args @ out_arg @ context_arg
|
|
|
|
(** [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
|
|
field by return value. *)
|
|
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 n md true in
|
|
|
|
(* Out vars for function calls *)
|
|
let out_vars =
|
|
unique
|
|
(List.map (fun obj -> out_var_name_of_objn (cname_of_qn obj.o_class),
|
|
Cty_id (qn_append obj.o_class "_out"))
|
|
(List.filter (fun obj -> not (is_op obj.o_class)) objs)) in
|
|
|
|
(* The body *)
|
|
let mems = List.map cvar_of_vd (mem@md.m_outputs) in
|
|
let var_env = args @ mems @ out_vars in
|
|
let vr = vr_compose
|
|
(vr_field (Cderef (Cvar "_out")) (ident_set_of_var_decs md.m_outputs))
|
|
(vr_direct (ident_set_of_var_decs md.m_inputs))
|
|
in
|
|
let body =
|
|
cstm_of_act_list vr var_env obj_env md.m_body
|
|
in
|
|
|
|
Cfundef {
|
|
C.f_name = fun_name;
|
|
f_retty = Cty_void;
|
|
f_args = args;
|
|
f_body = {
|
|
var_decls = out_vars;
|
|
block_body = body
|
|
}
|
|
}
|
|
|
|
let async_ty n =
|
|
Cty_ptr (Cty_id (qn_append n "_async"))
|
|
|
|
let async_field_ptr name =
|
|
Caddrof (Cfield (Cderef (Cvar "_async"), local_qn name))
|
|
|
|
let fun_stub_def_of_step_fun n md copy_in copy_out =
|
|
let fun_name = (cname_of_qn n) ^ "_step_async_stub" in
|
|
let args = (step_fun_args n md false) @ [("_async", async_ty n)] in
|
|
let out_vars = [("_in", Cty_id (qn_append n "_in"))] in
|
|
|
|
let prologue = List.flatten (List.map
|
|
(fun (src_name, ty) ->
|
|
let src = Cvar src_name in
|
|
let dest = CLfield (CLvar "_in", local_qn src_name) in
|
|
create_affect_stm dest src ty)
|
|
(inputlist_of_ovarlist md.m_inputs))
|
|
in
|
|
let body = [
|
|
Csexpr (Cfun_call (copy_in, [async_field_ptr "in"; Caddrof (Cvar "_in")]));
|
|
Csexpr (Cfun_call (copy_out, [Cvar "_out"; async_field_ptr "out"]))
|
|
] in
|
|
|
|
Cfundef {
|
|
C.f_name = fun_name;
|
|
f_retty = Cty_void;
|
|
f_args = args;
|
|
f_body = {
|
|
var_decls = out_vars;
|
|
block_body = prologue @ body
|
|
}
|
|
}
|
|
|
|
let async_fun_def_of_step_fun n obj_env mem objs md copy_in copy_out =
|
|
let fun_name = (cname_of_qn n) ^ "_async_step" in
|
|
let args = [("_async", async_ty n)] in
|
|
|
|
(* Out vars for function calls *)
|
|
let out_vars =
|
|
unique
|
|
(List.map (fun obj -> out_var_name_of_objn (cname_of_qn obj.o_class),
|
|
Cty_id (qn_append obj.o_class "_out"))
|
|
(List.filter (fun obj -> not (is_op obj.o_class)) objs)) in
|
|
|
|
let out_vars =
|
|
List.fold_left
|
|
(fun out_vars s -> ("_local" ^ s, Cty_id (qn_append n s)) :: out_vars)
|
|
out_vars
|
|
["_in"; "_out"]
|
|
in
|
|
|
|
(* FIXME(Arduino): it is probably easier to access to self directly from
|
|
_async struct pointer, but the string "self" is hardcoded in a large
|
|
number of places… *)
|
|
let out_vars =
|
|
if is_stateful n then
|
|
("self", Cty_ptr (Cty_id (qn_append n "_mem"))) :: out_vars
|
|
else
|
|
out_vars
|
|
in
|
|
|
|
(* The body *)
|
|
let mems = List.map cvar_of_vd (mem@md.m_outputs) in
|
|
let var_env = args @ mems @ out_vars in
|
|
|
|
let async_field_ptr name =
|
|
Caddrof (Cfield (Cderef (Cvar "_async"), local_qn name))
|
|
in
|
|
|
|
let l_in = Cvar "_local_in" in
|
|
let l_out = Cvar "_local_out" in
|
|
|
|
let vr = vr_compose
|
|
(vr_field l_out (ident_set_of_var_decs md.m_outputs))
|
|
(vr_field l_in (ident_set_of_var_decs md.m_inputs))
|
|
in
|
|
|
|
let prologue = [
|
|
Csexpr (Cfun_call (copy_in, [Caddrof l_in; async_field_ptr "in"]))
|
|
] in
|
|
let prologue =
|
|
if is_stateful n then
|
|
(Caffect (CLvar "self", async_field_ptr "self")) :: prologue
|
|
else
|
|
prologue
|
|
in
|
|
let body = cstm_of_act_list vr var_env obj_env md.m_body in
|
|
let epilogue = [
|
|
Csexpr (Cfun_call (copy_out, [async_field_ptr "out"; Caddrof l_out]))
|
|
] in
|
|
|
|
Cfundef {
|
|
C.f_name = fun_name;
|
|
f_retty = Cty_void;
|
|
f_args = args;
|
|
f_body = {
|
|
var_decls = out_vars;
|
|
block_body = prologue @ body @ epilogue
|
|
}
|
|
}
|
|
|
|
(** [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 =
|
|
if is_stateful od.o_class then
|
|
let ty = Cty_id (qn_append od.o_class "_mem") in
|
|
let ty = match od.o_size with
|
|
| Some nl ->
|
|
let rec mk_idx nl = match nl with
|
|
| [] -> ty
|
|
| n::nl -> Cty_arr (int_of_static_exp n, mk_idx nl)
|
|
in
|
|
mk_idx nl
|
|
| None -> ty in
|
|
(name od.o_ident, ty)::l
|
|
else
|
|
l
|
|
in
|
|
if is_stateful 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 ((cname_of_qn cd.cd_name) ^ "_mem",
|
|
mem_fields @ obj_fields)]
|
|
) else
|
|
[]
|
|
|
|
let in_decl_of_class_def cd =
|
|
let step_m = find_step_method cd in
|
|
let in_fields = List.map cvar_of_vd step_m.m_inputs in
|
|
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_in", in_fields)]
|
|
|
|
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 ((cname_of_qn cd.cd_name) ^ "_out", out_fields)]
|
|
|
|
let async_decl_of_class_def cd =
|
|
let struct_field suffix name =
|
|
let qn = qn_append cd.cd_name suffix in
|
|
(name, Cty_id qn)
|
|
in
|
|
let fields = [
|
|
struct_field "_in" "in";
|
|
struct_field "_out" "out"
|
|
] in
|
|
let fields = if is_stateful cd.cd_name then
|
|
(struct_field "_mem" "self") :: fields
|
|
else
|
|
fields
|
|
in
|
|
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_async", fields)]
|
|
|
|
(** [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 =
|
|
let body =
|
|
if cd.cd_stateful then
|
|
let var_env = List.map cvar_of_vd cd.cd_mems in
|
|
let vr = vr_direct IdentSet.empty in
|
|
let reset = find_reset_method cd in
|
|
cstm_of_act_list vr var_env cd.cd_objs reset.m_body
|
|
else
|
|
[]
|
|
in
|
|
Cfundef {
|
|
C.f_name = (cname_of_qn cd.cd_name) ^ "_reset";
|
|
f_retty = Cty_void;
|
|
f_args = [("self", Cty_ptr (Cty_id (qn_append cd.cd_name "_mem")))];
|
|
f_body = {
|
|
var_decls = [];
|
|
block_body = body;
|
|
}
|
|
}
|
|
|
|
let filter_async_objs cd =
|
|
List.filter
|
|
(fun od ->
|
|
match od.o_ack with
|
|
| Some _ -> true
|
|
| None -> false)
|
|
cd.cd_objs
|
|
|
|
let async_global_objs_defs cd =
|
|
List.map
|
|
(fun od ->
|
|
let name = async_global_var_name od in
|
|
let ty = Cty_id (qn_append od.o_class "_async") in
|
|
Cvardef (name, ty))
|
|
(filter_async_objs cd)
|
|
|
|
(** [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"]. *)
|
|
Idents.enter_node cd.cd_name;
|
|
let step_m = find_step_method cd in
|
|
let memory_struct_decl = mem_decl_of_class_def cd in
|
|
let in_struct_decl = in_decl_of_class_def cd in
|
|
let out_struct_decl = out_decl_of_class_def cd in
|
|
let async_struct_decl = async_decl_of_class_def cd in
|
|
let objs = async_global_objs_defs cd in
|
|
let step = fun_def_of_step_fun cd.cd_name cd.cd_objs cd.cd_mems
|
|
cd.cd_objs step_m in
|
|
(* TODO(Arduino): let the user choose the backend they want *)
|
|
let copy_in = AvrBackend.gen_copy_func_in cd in
|
|
let copy_out = AvrBackend.gen_copy_func_out cd in
|
|
let async_stub =
|
|
fun_stub_def_of_step_fun cd.cd_name step_m
|
|
(cdef_name copy_in) (cdef_name copy_out)
|
|
in
|
|
let async_step =
|
|
async_fun_def_of_step_fun cd.cd_name cd.cd_objs cd.cd_mems
|
|
cd.cd_objs step_m (cdef_name copy_in) (cdef_name copy_out)
|
|
in
|
|
(* C function for resetting our memory structure. *)
|
|
let reset = reset_fun_def_of_class_def cd in
|
|
|
|
let defs = [step; copy_in; copy_out; async_stub; async_step] in
|
|
let defs =
|
|
if is_stateful cd.cd_name then
|
|
reset :: defs
|
|
else
|
|
defs
|
|
in
|
|
let decls = List.map cdecl_of_cfundef defs in
|
|
|
|
memory_struct_decl @ in_struct_decl @ out_struct_decl @ async_struct_decl
|
|
@ decls, objs @ defs
|
|
|
|
(** {2 Type translation} *)
|
|
|
|
(** Translates an Obc type declaration to its C counterpart. *)
|
|
let cdefs_and_cdecls_of_type_decl otd =
|
|
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 of_string_fun = Cfundef
|
|
{ C.f_name = name ^ "_of_string";
|
|
f_retty = Cty_id otd.t_name;
|
|
f_args = [("s", Cty_ptr Cty_char)];
|
|
f_body =
|
|
{ var_decls = [];
|
|
block_body =
|
|
let gen_if t =
|
|
let t = cname_of_qn t and t' = t.name in
|
|
let funcall = Cfun_call ("strcmp", [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
|
|
{ C.f_name = "string_of_" ^ name;
|
|
f_retty = Cty_ptr Cty_char;
|
|
f_args = [("x", Cty_id otd.t_name); ("buf", Cty_ptr Cty_char)];
|
|
f_body =
|
|
{ var_decls = [];
|
|
block_body =
|
|
let gen_clause t =
|
|
let t = cname_of_qn t and t' = t.name in
|
|
let fun_call =
|
|
Cfun_call ("strcpy", [Cvar "buf";
|
|
Cconst (Cstrlit t')]) in
|
|
(t, [Csexpr fun_call]) in
|
|
[Cswitch (Cvar "x", map gen_clause nl);
|
|
Creturn (Cvar "buf")]; }
|
|
} in
|
|
([of_string_fun; to_string_fun],
|
|
[Cdecl_enum (name, List.map cname_of_qn nl);
|
|
cdecl_of_cfundef of_string_fun;
|
|
cdecl_of_cfundef to_string_fun])
|
|
| Type_struct fl ->
|
|
let decls = List.map (fun f -> cname_of_name f.Signature.f_name.name,
|
|
ctype_of_otype f.Signature.f_type) fl in
|
|
let decl = Cdecl_struct (name, decls) in
|
|
([], [decl])
|
|
|
|
let cdefs_and_cdecls_of_const_decl cd =
|
|
let name = cname_of_qn cd.c_name in
|
|
let v = cexpr_of_static_exp cd.Obc.c_value in
|
|
let cty = ctype_of_otype cd.Obc.c_type in
|
|
[], [Cdecl_constant (name, cty, v)]
|
|
|
|
let cdefs_and_cdecls_of_interface_decl id = match id with
|
|
| Itypedef td -> cdefs_and_cdecls_of_type_decl td
|
|
| Iconstdef cd -> cdefs_and_cdecls_of_const_decl cd
|
|
| _ -> [], []
|
|
|
|
let cdefs_and_cdecls_of_program_decl id = match id with
|
|
| Ptype td -> cdefs_and_cdecls_of_type_decl td
|
|
| Pconst cd -> cdefs_and_cdecls_of_const_decl cd
|
|
| _ -> [], []
|
|
|
|
let header_of_module m = match m with
|
|
| Module "Iostream" -> "stdio"
|
|
| _ -> String.uncapitalize_ascii (modul_to_string m)
|
|
|
|
(* Header files included in all generated XXX_types.h headers. *)
|
|
let common_types_c_headers = ["stdbool"; "assert"; "pervasives"]
|
|
|
|
let global_file_header name prog =
|
|
let dependencies = ModulSet.elements (Obc_utils.Deps.deps_program prog) in
|
|
let dependencies = List.map header_of_module dependencies in
|
|
|
|
let dependencies_types =
|
|
List.map
|
|
(function
|
|
"stdio" as s -> s
|
|
| s -> s ^ "_types")
|
|
dependencies in
|
|
|
|
let classes = program_classes prog in
|
|
let (decls, defs) =
|
|
List.split (List.map cdefs_and_cdecls_of_class_def classes) in
|
|
let decls = List.concat decls
|
|
and defs = List.concat defs in
|
|
|
|
let filename_types = name ^ "_types" in
|
|
let cdefs_and_cdecls = List.map cdefs_and_cdecls_of_program_decl prog.p_desc in
|
|
|
|
let (cty_defs, cty_decls) = List.split cdefs_and_cdecls in
|
|
let types_h = (filename_types ^ ".h",
|
|
Cheader (common_types_c_headers @ dependencies_types,
|
|
List.concat cty_decls)) in
|
|
let types_c = (filename_types ^ ".c", Csource (concat cty_defs)) in
|
|
|
|
let header =
|
|
(name ^ ".h", Cheader (filename_types :: dependencies, decls))
|
|
and source =
|
|
(name ^ ".c", Csource defs) in
|
|
[header; source; types_h; types_c]
|
|
|
|
|
|
let interface_header name i =
|
|
let dependencies = ModulSet.elements (Obc_utils.Deps.deps_interface i) in
|
|
let dependencies = List.map header_of_module dependencies in
|
|
|
|
let cdefs_and_cdecls = List.map cdefs_and_cdecls_of_interface_decl i.i_desc in
|
|
|
|
let (cty_defs, cty_decls) = List.split cdefs_and_cdecls in
|
|
let filename_types = name ^ "_types" in
|
|
let types_h = (filename_types ^ ".h",
|
|
Cheader (common_types_c_headers @ dependencies,
|
|
List.concat cty_decls)) in
|
|
let types_c = (filename_types ^ ".c", Csource (concat cty_defs)) in
|
|
let header = (name ^ ".h", Cheader ([filename_types], [])) in
|
|
let source = (name ^ ".c", Csource []) in
|
|
[header; source; types_h; types_c]
|