Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / c_backend.ml @ 1174cdd9

History | View | Annotate | Download (43.9 KB)

1
(* ----------------------------------------------------------------------------
2
 * SchedMCore - A MultiCore Scheduling Framework
3
 * Copyright (C) 2009-2013, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE
4
 * Copyright (C) 2012-2013, INPT, Toulouse, FRANCE
5
 *
6
 * This file is part of Prelude
7
 *
8
 * Prelude is free software; you can redistribute it and/or
9
 * modify it under the terms of the GNU Lesser General Public License
10
 * as published by the Free Software Foundation ; either version 2 of
11
 * the License, or (at your option) any later version.
12
 *
13
 * Prelude is distributed in the hope that it will be useful, but
14
 * WITHOUT ANY WARRANTY ; without even the implied warranty of
15
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16
 * Lesser General Public License for more details.
17
 *
18
 * You should have received a copy of the GNU Lesser General Public
19
 * License along with this program ; if not, write to the Free Software
20
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
21
 * USA
22
 *---------------------------------------------------------------------------- *)
23

    
24
(* This module is used for the lustre to C compiler *)
25

    
26
open Format
27
open LustreSpec
28
open Corelang
29
open Machine_code
30

    
31
(********************************************************************************************)
32
(*                     Basic      Printing functions                                        *)
33
(********************************************************************************************)
34

    
35
let print_version fmt =
36
  Format.fprintf fmt "/* @[<v>C code generated by %s@,SVN version number %s@,Code is %s compliant */@,@]@."
37
    (Filename.basename Sys.executable_name) Version.number (if !Options.ansi then "ANSI C90" else "C99")
38

    
39
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
40
let mk_self m =
41
  mk_new_name (m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory) "self"
42

    
43
(* Generation of a non-clashing name for the instance variable of static allocation macro *)
44
let mk_instance m =
45
  mk_new_name (m.mstep.step_inputs@m.mmemory) "inst"
46

    
47
(* Generation of a non-clashing name for the attribute variable of static allocation macro *)
48
let mk_attribute m =
49
  mk_new_name (m.mstep.step_inputs@m.mmemory) "attr"
50

    
51
let mk_call_var_decl loc id =
52
  { var_id = id;
53
    var_dec_type = mktyp Location.dummy_loc Tydec_any;
54
    var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
55
    var_dec_const = false;
56
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
57
    var_clock = Clocks.new_var true;
58
    var_loc = loc }
59

    
60
(* counter for loop variable creation *)
61
let loop_cpt = ref (-1)
62

    
63
let reset_loop_counter () =
64
 loop_cpt := -1
65

    
66
let mk_loop_var m () =
67
  let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in
68
  let rec aux () =
69
    incr loop_cpt;
70
    let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in
71
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
72
  in aux ()
73
(*
74
let addr_cpt = ref (-1)
75

    
76
let reset_addr_counter () =
77
 addr_cpt := -1
78

    
79
let mk_addr_var m var =
80
  let vars = m.mmemory in
81
  let rec aux () =
82
    incr addr_cpt;
83
    let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
84
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
85
  in aux ()
86
*)
87
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
88
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
89
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
90
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
91
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
92
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
93
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
94
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
95

    
96
let pp_c_dimension fmt d =
97
 fprintf fmt "%a" Dimension.pp_dimension d
98

    
99
let pp_c_type var fmt t =
100
  let rec aux t pp_suffix =
101
  match (Types.repr t).Types.tdesc with
102
  | Types.Tclock t'       -> aux t' pp_suffix
103
  | Types.Tbool           -> fprintf fmt "_Bool %s%a" var pp_suffix ()
104
  | Types.Treal           -> fprintf fmt "double %s%a" var pp_suffix ()
105
  | Types.Tint            -> fprintf fmt "int %s%a" var pp_suffix ()
106
  | Types.Tarray (d, t')  ->
107
    let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
108
    aux t' pp_suffix'
109
  | Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
110
  | Types.Tconst ty       -> fprintf fmt "%s %s" ty var
111
  | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var
112
  | _                     -> eprintf "internal error: pp_c_type %a@." Types.print_ty t; assert false
113
  in aux t (fun fmt () -> ())
114

    
115
let rec pp_c_initialize fmt t = 
116
  match (Types.repr t).Types.tdesc with
117
  | Types.Tint -> pp_print_string fmt "0"
118
  | Types.Tclock t' -> pp_c_initialize fmt t'
119
  | Types.Tbool -> pp_print_string fmt "0" 
120
  | Types.Treal -> pp_print_string fmt "0."
121
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
122
    fprintf fmt "{%a}"
123
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
124
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
125
  | _ -> assert false
126

    
127
(* Declaration of an input variable:
128
   - if its type is array/matrix/etc, then declare it as a mere pointer,
129
     in order to cope with unknown/parametric array dimensions, 
130
     as it is the case for generics
131
*)
132
let pp_c_decl_input_var fmt id =
133
  if !Options.ansi && Types.is_address_type id.var_type
134
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
135
  else pp_c_type id.var_id fmt id.var_type
136

    
137
(* Declaration of an output variable:
138
   - if its type is scalar, then pass its address
139
   - if its type is array/matrix/struct/etc, then declare it as a mere pointer,
140
     in order to cope with unknown/parametric array dimensions, 
141
     as it is the case for generics
142
*)
143
let pp_c_decl_output_var fmt id =
144
  if (not !Options.ansi) && Types.is_address_type id.var_type
145
  then pp_c_type                  id.var_id  fmt id.var_type
146
  else pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
147

    
148
(* Declaration of a local/mem variable:
149
   - if it's an array/matrix/etc, its size(s) should be
150
     known in order to statically allocate memory, 
151
     so we print the full type
152
*)
153
let pp_c_decl_local_var fmt id =
154
  pp_c_type id.var_id fmt id.var_type
155

    
156
let pp_c_decl_array_mem self fmt id =
157
  fprintf fmt "%a = (%a) (%s->_reg.%s)"
158
    (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
159
    (pp_c_type "(*)") id.var_type
160
    self
161
    id.var_id
162

    
163
(* Declaration of a struct variable:
164
   - if it's an array/matrix/etc, we declare it as a pointer
165
*)
166
let pp_c_decl_struct_var fmt id =
167
  if Types.is_array_type id.var_type
168
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
169
  else pp_c_type                  id.var_id  fmt id.var_type
170

    
171
(* Access to the value of a variable:
172
   - if it's not a scalar output, then its name is enough
173
   - otherwise, dereference it (it has been declared as a pointer,
174
     despite its scalar Lustre type)
175
   - moreover, dereference memory array variables.
176
*)
177
let pp_c_var_read m fmt id =
178
  if Types.is_address_type id.var_type
179
  then
180
    if is_memory m id
181
    then fprintf fmt "(*%s)" id.var_id
182
    else fprintf fmt "%s" id.var_id
183
  else
184
    if is_output m id
185
    then fprintf fmt "*%s" id.var_id
186
    else fprintf fmt "%s" id.var_id
187

    
188
(* Addressable value of a variable, the one that is passed around in calls:
189
   - if it's not a scalar non-output, then its name is enough
190
   - otherwise, reference it (it must be passed as a pointer,
191
     despite its scalar Lustre type)
192
*)
193
let pp_c_var_write m fmt id =
194
  if Types.is_address_type id.var_type
195
  then
196
    fprintf fmt "%s" id.var_id
197
  else
198
    if is_output m id
199
    then
200
      fprintf fmt "%s" id.var_id
201
    else
202
      fprintf fmt "&%s" id.var_id
203

    
204
let pp_c_decl_instance_var fmt (name, (node, static)) = 
205
  fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
206

    
207
let pp_c_tag fmt t =
208
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
209

    
210
(* Prints a constant value *)
211
let rec pp_c_const fmt c =
212
  match c with
213
    | Const_int i     -> pp_print_int fmt i
214
    | Const_real r    -> pp_print_string fmt r
215
    | Const_float r   -> pp_print_float fmt r
216
    | Const_tag t     -> pp_c_tag fmt t
217
    | Const_array ca  -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
218
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
219

    
220
(* Prints a value expression [v], with internal function calls only.
221
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
222
   but an offset suffix may be added for array variables
223
*)
224
let rec pp_c_val self pp_var fmt v =
225
  match v with
226
    | Cst c         -> pp_c_const fmt c
227
    | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
228
    | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
229
    | Power (v, n)  -> assert false
230
    | LocalVar v    -> pp_var fmt v
231
    | StateVar v    ->
232
    (* array memory vars are represented by an indirection to a local var with the right type,
233
       in order to avoid casting everywhere. *)
234
      if Types.is_array_type v.var_type
235
      then fprintf fmt "%a" pp_var v
236
      else fprintf fmt "%s->_reg.%a" self pp_var v
237
    | Fun (n, vl)   -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
238

    
239
let pp_c_checks self fmt m =
240
  Utils.fprintf_list ~sep:"" (fun fmt (loc, check) -> fprintf fmt "@[<v>%a@,assert (%a);@]@," Location.pp_c_loc loc (pp_c_val self (pp_c_var_read m)) check) fmt m.mstep.step_checks
241

    
242

    
243
(********************************************************************************************)
244
(*                    Instruction Printing functions                                        *)
245
(********************************************************************************************)
246

    
247
(* Computes the depth to which multi-dimension array assignments should be expanded.
248
   It equals the maximum number of nested static array constructions accessible from root [v].
249
*)
250
let rec expansion_depth v =
251
 match v with
252
 | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
253
 | Cst _
254
 | LocalVar _
255
 | StateVar _  -> 0
256
 | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
257
 | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
258
 | Access (v, i) -> max 0 (expansion_depth v - 1)
259
 | Power (v, n)  -> 0 (*1 + expansion_depth v*)
260

    
261
type loop_index = LVar of ident | LInt of int ref
262

    
263
(* Computes the list of nested loop variables together with their dimension bounds.
264
   - LInt r stands for loop expansion (no loop variable, but int loop index)
265
   - LVar v stands for loop variable v
266
*)
267
let rec mk_loop_variables m ty depth =
268
 match (Types.repr ty).Types.tdesc, depth with
269
 | Types.Tarray (d, ty'), 0       ->
270
   let v = mk_loop_var m () in
271
   (d, LVar v) :: mk_loop_variables m ty' 0
272
 | Types.Tarray (d, ty'), _       ->
273
   let r = ref (-1) in
274
   (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
275
 | _                    , 0       -> []
276
 | _                              -> assert false
277

    
278
let reorder_loop_variables loop_vars =
279
  let (int_loops, var_loops) = List.partition (function (d, LInt _) -> true | _ -> false) loop_vars in
280
  var_loops @ int_loops
281

    
282
(* Prints a one loop variable suffix for arrays *)
283
let pp_loop_var fmt lv =
284
 match snd lv with
285
 | LVar v -> fprintf fmt "[%s]" v
286
 | LInt r -> fprintf fmt "[%d]" !r
287

    
288
(* Prints a suffix of loop variables for arrays *)
289
let pp_suffix fmt loop_vars =
290
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
291

    
292
(* Prints a [value] indexed by the suffix list [loop_vars] *)
293
let rec pp_value_suffix self loop_vars pp_value fmt value =
294
 match loop_vars, value with
295
 | (_, LInt r) :: q, Array vl     ->
296
   pp_value_suffix self q pp_value fmt (List.nth vl !r)
297
 | _           :: q, Power (v, n) ->
298
   pp_value_suffix self loop_vars pp_value fmt v
299
 | _               , Fun (n, vl)  ->
300
   Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
301
 | _               , _            ->
302
   let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
303
   pp_c_val self pp_var_suffix fmt value
304

    
305
(* type_directed assignment: array vs. statically sized type
306
   - [var_type]: type of variable to be assigned
307
   - [var_name]: name of variable to be assigned
308
   - [value]: assigned value
309
   - [pp_var]: printer for variables
310
*)
311
let pp_assign m self pp_var fmt var_type var_name value =
312
  let depth = expansion_depth value in
313
(*eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val value depth;*)
314
  let loop_vars = mk_loop_variables m var_type depth in
315
  let reordered_loop_vars = reorder_loop_variables loop_vars in
316
  let rec aux fmt vars =
317
    match vars with
318
    | [] ->
319
      fprintf fmt "%a = %a;" (pp_value_suffix self loop_vars pp_var) var_name (pp_value_suffix self loop_vars pp_var) value
320
    | (d, LVar i) :: q ->
321
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
322
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
323
	i i i Dimension.pp_dimension d i
324
	aux q
325
    | (d, LInt r) :: q ->
326
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
327
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
328
      fprintf fmt "@[<v 2>{@,%a@]@,}"
329
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
330
  in
331
  begin
332
    reset_loop_counter ();
333
    (*reset_addr_counter ();*)
334
    aux fmt reordered_loop_vars
335
  end
336

    
337
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
338
 try (* stateful node instance *)
339
   let (n,_) = List.assoc i m.minstances in
340
   fprintf fmt "%a (%a%t%a%t%s->%s);"
341
     pp_machine_step_name (node_name n)
342
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
343
     (Utils.pp_final_char_if_non_empty ", " inputs) 
344
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
345
     (Utils.pp_final_char_if_non_empty ", " outputs)
346
     self
347
     i
348
 with Not_found -> (* stateless node instance *)
349
   let (n,_) = List.assoc i m.mcalls in
350
   fprintf fmt "%a (%a%t%a);"
351
     pp_machine_step_name (node_name n)
352
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
353
     (Utils.pp_final_char_if_non_empty ", " inputs) 
354
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
355

    
356
let pp_machine_reset (m: machine_t) self fmt inst =
357
  let (node, static) = List.assoc inst m.minstances in
358
  fprintf fmt "%a(%a%t%s->%s);"
359
    pp_machine_reset_name (node_name node)
360
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
361
    (Utils.pp_final_char_if_non_empty ", " static)
362
    self inst
363

    
364
let has_c_prototype funname dependencies =
365
  let imported_node_opt = (* We select the last imported node with the name funname.
366
			       The order of evaluation of dependencies should be
367
			       compatible with overloading. (Not checked yet) *) 
368
      List.fold_left
369
	(fun res (_, _, decls) -> 
370
	  match res with
371
	  | Some _ -> res
372
	  | None -> 
373
	    let matched = fun t -> match t.top_decl_desc with 
374
	      | ImportedNode nd -> nd.nodei_id = funname 
375
	      | _ -> false
376
	    in
377
	    if List.exists matched decls then (
378
	      match (List.find matched decls).top_decl_desc with
379
	      | ImportedNode nd -> Some nd
380
	      | _ -> assert false
381
	    )
382
	    else
383
	      None
384
	) None dependencies in
385
    match imported_node_opt with
386
    | None -> false
387
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
388

    
389
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
390
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
391
    (pp_c_val self (pp_c_var_read m)) c
392
    (Utils.pp_newline_if_non_empty tl)
393
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
394
    (Utils.pp_newline_if_non_empty el)
395
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el
396

    
397
and pp_machine_instr dependencies (m: machine_t) self fmt instr =
398
  match instr with 
399
  | MReset i ->
400
    pp_machine_reset m self fmt i
401
  | MLocalAssign (i,v) ->
402
    pp_assign
403
      m self (pp_c_var_read m) fmt
404
      i.var_type (LocalVar i) v
405
  | MStateAssign (i,v) ->
406
    pp_assign
407
      m self (pp_c_var_read m) fmt
408
      i.var_type (StateVar i) v
409
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
410
    pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl)))
411
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
412
    fprintf fmt "%a = %s(%a);" 
413
      (pp_c_val self (pp_c_var_read m)) (LocalVar i0) 
414
      i
415
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
416
  | MStep (il, i, vl) ->
417
    pp_instance_call m self fmt i vl il
418
  | MBranch (g,hl) ->
419
    if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false
420
    then (* boolean case, needs special treatment in C because truth value is not unique *)
421
	 (* may disappear if we optimize code by replacing last branch test with default *)
422
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
423
      let el = try List.assoc tag_false hl with Not_found -> [] in
424
      pp_conditional dependencies m self fmt g tl el
425
    else (* enum type case *)
426
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
427
	(pp_c_val self (pp_c_var_read m)) g
428
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
429

    
430
and pp_machine_branch dependencies m self fmt (t, h) =
431
  fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h
432

    
433

    
434
(**************************************************************************)
435
(*     Printing spec for c *)
436

    
437
(**************************************************************************)
438

    
439

    
440
let pp_econst fmt c = 
441
  match c with
442
    | EConst_int i -> pp_print_int fmt i
443
    | EConst_real r -> pp_print_string fmt r
444
    | EConst_float r -> pp_print_float fmt r
445
    | EConst_bool b -> pp_print_bool fmt b
446
    | EConst_string s -> pp_print_string fmt ("\"" ^ s ^ "\"")
447

    
448
let rec pp_eexpr is_output fmt eexpr = 
449
  let pp_eexpr = pp_eexpr is_output in
450
  match eexpr.eexpr_desc with
451
    | EExpr_const c -> pp_econst fmt c
452
    | EExpr_ident id -> 
453
      if is_output id then pp_print_string fmt ("*" ^ id) else pp_print_string fmt id
454
    | EExpr_tuple el -> Utils.fprintf_list ~sep:"," pp_eexpr fmt el
455
    | EExpr_arrow (e1, e2) -> fprintf fmt "%a -> %a" pp_eexpr e1 pp_eexpr e2
456
    | EExpr_fby (e1, e2) -> fprintf fmt "%a fby %a" pp_eexpr e1 pp_eexpr e2
457
    (* | EExpr_concat (e1, e2) -> fprintf fmt "%a::%a" pp_eexpr e1 pp_eexpr e2 *)
458
    (* | EExpr_tail e -> fprintf fmt "tail %a" pp_eexpr e *)
459
    | EExpr_pre e -> fprintf fmt "pre %a" pp_eexpr e
460
    | EExpr_when (e, id) -> fprintf fmt "%a when %s" pp_eexpr e id
461
    | EExpr_merge (id, e1, e2) -> 
462
      fprintf fmt "merge (%s, %a, %a)" id pp_eexpr e1 pp_eexpr e2
463
    | EExpr_appl (id, e, r) -> pp_eapp is_output fmt id e r
464
    | EExpr_forall (vars, e) -> fprintf fmt "forall %a; %a" Printers.pp_node_args vars pp_eexpr e 
465
    | EExpr_exists (vars, e) -> fprintf fmt "exists %a; %a" Printers.pp_node_args vars pp_eexpr e 
466

    
467

    
468
    (* | EExpr_whennot _ *)
469
    (* | EExpr_uclock _ *)
470
    (* | EExpr_dclock _ *)
471
    (* | EExpr_phclock _ -> assert false *)
472
and pp_eapp is_output fmt id e r =
473
  let pp_eexpr = pp_eexpr is_output in
474
  match r with
475
  | None ->
476
    (match id, e.eexpr_desc with
477
    | "+", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a + %a)" pp_eexpr e1 pp_eexpr e2
478
    | "uminus", _ -> fprintf fmt "(- %a)" pp_eexpr e
479
    | "-", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a - %a)" pp_eexpr e1 pp_eexpr e2
480
    | "*", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a * %a)" pp_eexpr e1 pp_eexpr e2
481
    | "/", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a / %a)" pp_eexpr e1 pp_eexpr e2
482
    | "mod", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a mod %a)" pp_eexpr e1 pp_eexpr e2
483
    | "&&", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a && %a)" pp_eexpr e1 pp_eexpr e2
484
    | "||", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a || %a)" pp_eexpr e1 pp_eexpr e2
485
    | "xor", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a ^^ %a)" pp_eexpr e1 pp_eexpr e2
486
    | "impl", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a ==> %a)" pp_eexpr e1 pp_eexpr e2
487
    | "<", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a < %a)" pp_eexpr e1 pp_eexpr e2
488
    | "<=", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a <= %a)" pp_eexpr e1 pp_eexpr e2
489
    | ">", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a > %a)" pp_eexpr e1 pp_eexpr e2
490
    | ">=", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a >= %a)" pp_eexpr e1 pp_eexpr e2
491
    | "!=", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a != %a)" pp_eexpr e1 pp_eexpr e2
492
    | "=", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a == %a)" pp_eexpr e1 pp_eexpr e2
493
    | "not", _ -> fprintf fmt "(! %a)" pp_eexpr e
494
    | "ite", EExpr_tuple([e1;e2;e3]) -> fprintf fmt "(if %a then %a else %a)" pp_eexpr e1 pp_eexpr e2 pp_eexpr e3
495
    | _ -> fprintf fmt "%s (%a)" id pp_eexpr e)
496
  | Some x -> fprintf fmt "%s (%a) every %s" id pp_eexpr e x 
497

    
498
let pp_ensures is_output fmt e =
499
  match e with
500
    | EnsuresExpr e -> fprintf fmt "ensures %a;@ " (pp_eexpr is_output) e
501
    | SpecObserverNode (name, args) -> fprintf fmt "observer %s (%a);@ " name (Utils.fprintf_list ~sep:", " (pp_eexpr is_output)) args
502

    
503
let pp_acsl_spec outputs fmt spec =
504
  let is_output = fun oid -> List.exists (fun v -> v.var_id = oid) outputs in
505
  let pp_eexpr = pp_eexpr is_output in
506
  fprintf fmt "@[<v 2>/*@@ ";
507
  Utils.fprintf_list ~sep:"" (fun fmt r -> fprintf fmt "requires %a;@ " pp_eexpr r) fmt spec.requires;
508
  Utils.fprintf_list ~sep:"" (pp_ensures is_output) fmt spec.ensures;
509
  fprintf fmt "@ ";
510
  (* fprintf fmt "assigns *self%t%a;@ "  *)
511
  (*   (fun fmt -> if List.length outputs > 0 then fprintf fmt ", ") *)
512
  (*   (fprintf_list ~sep:"," (fun fmt v -> fprintf fmt "*%s" v.var_id)) outputs; *)
513
  Utils.fprintf_list ~sep:"@ " (fun fmt (name, assumes, requires) -> 
514
    fprintf fmt "behavior %s:@[@ %a@ %a@]" 
515
      name
516
      (Utils.fprintf_list ~sep:"@ " (fun fmt r -> fprintf fmt "assumes %a;" pp_eexpr r)) assumes
517
      (Utils.fprintf_list ~sep:"@ " (pp_ensures is_output)) requires
518
  ) fmt spec.behaviors;
519
  fprintf fmt "@]@ */@.";
520
  ()
521

    
522
(********************************************************************************************)
523
(*                      Prototype Printing functions                                        *)
524
(********************************************************************************************)
525

    
526
let print_alloc_prototype fmt (name, static) =
527
  fprintf fmt "%a * %a (%a)"
528
    pp_machine_memtype_name name
529
    pp_machine_alloc_name name
530
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
531

    
532
let print_reset_prototype self fmt (name, static) =
533
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
534
    pp_machine_reset_name name
535
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
536
    (Utils.pp_final_char_if_non_empty ",@," static) 
537
    pp_machine_memtype_name name
538
    self
539

    
540
let print_stateless_prototype fmt (name, inputs, outputs) =
541
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
542
    pp_machine_step_name name
543
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
544
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
545
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
546

    
547
let print_step_prototype self fmt (name, inputs, outputs) =
548
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
549
    pp_machine_step_name name
550
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
551
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
552
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
553
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
554
    pp_machine_memtype_name name
555
    self
556

    
557
(********************************************************************************************)
558
(*                         Header Printing functions                                        *)
559
(********************************************************************************************)
560

    
561

    
562
let print_import_standard fmt =
563
  fprintf fmt "#include \"%s/include/lustrec/arrow.h\"@.@." Version.prefix
564

    
565
let print_import_prototype fmt (s, _, _) =
566
  fprintf fmt "#include \"%s.h\"@," s
567
    
568
let pp_registers_struct fmt m =
569
  if m.mmemory <> []
570
  then
571
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
572
      pp_machine_regtype_name m.mname.node_id
573
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
574
  else
575
    ()
576

    
577
let print_machine_struct fmt m =
578
  if fst (get_stateless_status m) then
579
    begin
580
    end
581
  else
582
    begin
583
      (* Define struct *)
584
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
585
	pp_machine_memtype_name m.mname.node_id
586
	pp_registers_struct m
587
	(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
588
	(Utils.pp_final_char_if_non_empty "; " m.minstances)
589
    end
590

    
591
let print_static_declare_instance attr fmt (i, (m, static)) =
592
  fprintf fmt "%a(%s, %a%t%s)"
593
    pp_machine_static_declare_name (node_name m)
594
    attr
595
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
596
    (Utils.pp_final_char_if_non_empty ", " static)
597
    i
598

    
599
let print_static_declare_macro fmt m =
600
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
601
  let inst = mk_instance m in
602
  let attr = mk_attribute m in
603
  fprintf fmt "@[<v 2>#define %a(%s, %a%t%s)\\@,%s %a %s;\\@,%a%t%a;@,@]"
604
    pp_machine_static_declare_name m.mname.node_id
605
    attr
606
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
607
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
608
    inst
609
    attr
610
    pp_machine_memtype_name m.mname.node_id
611
    inst
612
    (Utils.fprintf_list ~sep:";\\@," pp_c_decl_local_var) array_mem
613
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
614
    (Utils.fprintf_list ~sep:";\\@,"
615
       (fun fmt (i',m') ->
616
	 let path = sprintf "inst ## _%s" i' in
617
	 fprintf fmt "%a"
618
	   (print_static_declare_instance attr) (path,m')
619
       )) m.minstances
620

    
621
      
622
let print_static_link_instance fmt (i, (m, _)) =
623
 fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
624

    
625
(* Allocation of a node struct:
626
   - if node memory is an array/matrix/etc, we cast it to a pointer (see pp_registers_struct)
627
*)
628
let print_static_link_macro fmt m =
629
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
630
  fprintf fmt "@[<v>@[<v 2>#define %a(inst) do {\\@,%a%t%a;\\@]@,} while (0)@.@]"
631
    pp_machine_static_link_name m.mname.node_id
632
    (Utils.fprintf_list ~sep:";\\@,"
633
       (fun fmt v ->
634
	 fprintf fmt "inst._reg.%s = (%a*) &%s"
635
	   v.var_id
636
           (fun fmt v -> pp_c_type "" fmt (Types.array_base_type v.var_type)) v
637
	   v.var_id
638
       )) array_mem
639
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
640
    (Utils.fprintf_list ~sep:";\\@,"
641
       (fun fmt (i',m') ->
642
	 let path = sprintf "inst ## _%s" i' in
643
	 fprintf fmt "%a;\\@,inst.%s = &%s"
644
	   print_static_link_instance (path,m')
645
	   i'
646
	   path
647
       )) m.minstances
648
      
649
let print_static_alloc_macro fmt m =
650
  fprintf fmt "@[<v>@[<v 2>#define %a(attr,%a%tinst)\\@,%a(attr,%a%tinst);\\@,%a(inst);@]@,@]@."
651
    pp_machine_static_alloc_name m.mname.node_id
652
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
653
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
654
    pp_machine_static_declare_name m.mname.node_id
655
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
656
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
657
    pp_machine_static_link_name m.mname.node_id
658

    
659
let print_machine_decl fmt m =
660
  if fst (get_stateless_status m) then
661
    begin
662
      (* Print specification if any *)
663
      (match m.mspec with
664
      | None -> ()
665
      | Some spec -> 
666
	pp_acsl_spec m.mstep.step_outputs fmt spec
667
      );
668
      fprintf fmt "extern %a;@.@."
669
	print_stateless_prototype
670
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
671
    end
672
  else
673
    begin
674
      (* Static allocation *)
675
      if !Options.static_mem
676
      then (
677
	fprintf fmt "%a@.%a@.%a@."
678
	  print_static_declare_macro m
679
	  print_static_link_macro m
680
	  print_static_alloc_macro m
681
      )
682
      else ( 
683
        (* Dynamic allocation *)
684
	fprintf fmt "extern %a;@.@."
685
	  print_alloc_prototype (m.mname.node_id, m.mstatic)
686
      );
687
      let self = mk_self m in
688
      fprintf fmt "extern %a;@.@."
689
	(print_reset_prototype self) (m.mname.node_id, m.mstatic);
690
      (* Print specification if any *)
691
      (match m.mspec with
692
      | None -> ()
693
      | Some spec -> 
694
	pp_acsl_spec m.mstep.step_outputs fmt spec
695
      );
696
      fprintf fmt "extern %a;@.@."
697
	(print_step_prototype self)
698
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
699
    end
700

    
701

    
702
(********************************************************************************************)
703
(*                         C file Printing functions                                        *)
704
(********************************************************************************************)
705

    
706
let print_const_def fmt cdecl =
707
  fprintf fmt "%a = %a;@." (pp_c_type cdecl.const_id) cdecl.const_type pp_c_const cdecl.const_value 
708

    
709
let print_const_decl fmt cdecl =
710
  fprintf fmt "extern %a;@." (pp_c_type cdecl.const_id) cdecl.const_type
711

    
712
let print_alloc_instance fmt (i, (m, static)) =
713
  fprintf fmt "_alloc->%s = %a (%a);@,"
714
    i
715
    pp_machine_alloc_name (node_name m)
716
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
717

    
718
let print_alloc_array fmt vdecl =
719
  let base_type = Types.array_base_type vdecl.var_type in
720
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
721
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
722
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
723
    vdecl.var_id
724
    (pp_c_type "") base_type
725
    Dimension.pp_dimension size_type
726
    (pp_c_type "") base_type
727
    vdecl.var_id
728

    
729
let print_alloc_code fmt m =
730
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
731
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
732
    pp_machine_memtype_name m.mname.node_id
733
    pp_machine_memtype_name m.mname.node_id
734
    pp_machine_memtype_name m.mname.node_id
735
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
736
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
737

    
738
let print_stateless_code dependencies fmt m =
739
  let self = "__ERROR__" in
740
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
741
  then
742
    (* C99 code *)
743
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
744
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
745
      (* locals *)
746
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
747
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
748
      (* check assertions *)
749
      (pp_c_checks self) m
750
      (* instrs *)
751
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
752
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
753
      (fun fmt -> fprintf fmt "return;")
754
  else
755
    (* C90 code *)
756
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
757
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
758
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
759
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
760
      (* locals *)
761
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
762
      (Utils.pp_final_char_if_non_empty ";" base_locals)
763
      (* check assertions *)
764
      (pp_c_checks self) m
765
      (* instrs *)
766
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
767
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
768
      (fun fmt -> fprintf fmt "return;")
769

    
770
let print_reset_code dependencies fmt m self =
771
  fprintf fmt "@[<v 2>%a {@,%a%treturn;@]@,}@.@."
772
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
773
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
774
    (Utils.pp_newline_if_non_empty m.minit)
775

    
776
let print_step_code dependencies fmt m self =
777
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
778
  then
779
    (* C99 code *)
780
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
781
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@."
782
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
783
      (* locals *)
784
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
785
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
786
      (* array mems *)
787
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
788
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
789
      (* check assertions *)
790
      (pp_c_checks self) m
791
      (* instrs *)
792
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
793
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
794
      (fun fmt -> fprintf fmt "return;")
795
  else
796
    (* C90 code *)
797
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
798
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
799
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
800
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
801
      (* locals *)
802
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
803
      (Utils.pp_final_char_if_non_empty ";" base_locals)
804
      (* check assertions *)
805
      (pp_c_checks self) m
806
      (* instrs *)
807
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
808
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
809
      (fun fmt -> fprintf fmt "return;")
810

    
811
let print_machine dependencies fmt m =
812
  if fst (get_stateless_status m) then
813
    begin
814
      (* Step function *)
815
      print_stateless_code dependencies fmt m
816
    end
817
  else
818
    begin
819
      (* Alloc function, only if non static mode *)
820
      if (not !Options.static_mem) then  
821
	(
822
	  fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@."
823
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
824
	    print_alloc_code m;
825
	);
826
      let self = mk_self m in
827
      (* Reset function *)
828
      print_reset_code dependencies fmt m self;
829
      (* Step function *)
830
      print_step_code dependencies fmt m self
831
    end
832

    
833
(********************************************************************************************)
834
(*                         Main related functions                                           *)
835
(********************************************************************************************)
836

    
837
let print_get_input fmt v =
838
  match v.var_type.Types.tdesc with
839
    | Types.Tint -> fprintf fmt "_get_int(\"%s\")" v.var_id
840
    | Types.Tbool -> fprintf fmt "_get_bool(\"%s\")" v.var_id
841
    | Types.Treal -> fprintf fmt "_get_double(\"%s\")" v.var_id
842
    | _ -> assert false
843

    
844
let print_put_outputs fmt ol = 
845
  let po fmt o =
846
    match o.var_type.Types.tdesc with
847
    | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id
848
    | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id
849
    | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id
850
    | _ -> assert false
851
  in
852
  List.iter (fprintf fmt "@ %a;" po) ol
853

    
854
let print_main_fun machines m fmt =
855
  let mname = m.mname.node_id in
856
  let main_mem =
857
    if (!Options.static_mem && !Options.main_node <> "")
858
    then "&main_mem"
859
    else "main_mem" in
860
  fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ ";
861
  fprintf fmt "/* Declaration of inputs/outputs variables */@ ";
862
  List.iter 
863
    (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type pp_c_initialize v.var_type
864
    ) m.mstep.step_inputs;
865
  List.iter 
866
    (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type pp_c_initialize v.var_type
867
    ) m.mstep.step_outputs;
868
  fprintf fmt "@ /* Main memory allocation */@ ";
869
  if (!Options.static_mem && !Options.main_node <> "")
870
  then (fprintf fmt "%a(static,main_mem);@ " pp_machine_static_alloc_name mname)
871
  else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname);
872
  fprintf fmt "@ /* Initialize the main memory */@ ";
873
  fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem;
874
  fprintf fmt "@ ISATTY = isatty(0);@ ";
875
  fprintf fmt "@ /* Infinite loop */@ ";
876
  fprintf fmt "@[<v 2>while(1){@ ";
877
  fprintf fmt  "fflush(stdout);@ ";
878
  List.iter 
879
    (fun v -> fprintf fmt "%s = %a;@ "
880
      v.var_id
881
      print_get_input v
882
    ) m.mstep.step_inputs;
883
  (match m.mstep.step_outputs with
884
    (* | [] -> ( *)
885
    (*   fprintf fmt "%a(%a%t%s);@ "  *)
886
    (* 	pp_machine_step_name mname *)
887
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
888
    (* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
889
    (* 	main_mem *)
890
    (* ) *)
891
    (* | [o] -> ( *)
892
    (*   fprintf fmt "%s = %a(%a%t%a, %s);%a" *)
893
    (* 	o.var_id *)
894
    (* 	pp_machine_step_name mname *)
895
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
896
    (* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
897
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)
898
    (* 	main_mem *)
899
    (* 	print_put_outputs [o]) *)
900
    | _ -> (
901
      fprintf fmt "%a(%a%t%a, %s);%a"
902
	pp_machine_step_name mname
903
	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs
904
	(Utils.pp_final_char_if_non_empty ", " m.mstep.step_inputs)
905
	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs
906
	main_mem
907
	print_put_outputs m.mstep.step_outputs)
908
  );
909
  fprintf fmt "@]@ }@ ";
910
  fprintf fmt "return 1;";
911
  fprintf fmt "@]@ }@."       
912

    
913
let print_main_header fmt =
914
  fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"%s/include/lustrec/io_frontend.h\"@." Version.prefix
915

    
916
let rec pp_c_struct_type_field filename cpt fmt (label, tdesc) =
917
  fprintf fmt "%a;" (pp_c_type_decl filename cpt label) tdesc
918
and pp_c_type_decl filename cpt var fmt tdecl =
919
  match tdecl with
920
  | Tydec_any           -> assert false
921
  | Tydec_int           -> fprintf fmt "int %s" var
922
  | Tydec_real          -> fprintf fmt "double %s" var
923
  | Tydec_float         -> fprintf fmt "float %s" var
924
  | Tydec_bool          -> fprintf fmt "_Bool %s" var
925
  | Tydec_clock ty      -> pp_c_type_decl filename cpt var fmt ty
926
  | Tydec_const c       -> fprintf fmt "%s %s" c var
927
  | Tydec_array (d, ty) -> fprintf fmt "%a[%a]" (pp_c_type_decl filename cpt var) ty pp_c_dimension d
928
  | Tydec_enum tl ->
929
    begin
930
      incr cpt;
931
      fprintf fmt "enum _enum_%s_%d { %a } %s" filename !cpt (Utils.fprintf_list ~sep:", " pp_print_string) tl var
932
    end
933
  | Tydec_struct fl ->
934
    begin
935
      incr cpt;
936
      fprintf fmt "struct _struct_%s_%d { %a } %s" filename !cpt (Utils.fprintf_list ~sep:" " (pp_c_struct_type_field filename cpt)) fl var
937
    end
938

    
939
let print_type_definitions fmt filename =
940
  let cpt_type = ref 0 in
941
  Hashtbl.iter (fun typ def ->
942
    match typ with
943
    | Tydec_const var ->
944
      fprintf fmt "typedef %a;@.@."
945
	(pp_c_type_decl filename cpt_type var) def
946
    | _        -> ()) type_table
947

    
948

    
949
let header_has_code header =
950
  List.exists 
951
    (fun top -> 
952
      match top.top_decl_desc with
953
      | Consts _ -> true 
954
      | ImportedNode nd -> nd.nodei_in_lib = None
955
      | _ -> false
956
    )
957
    header
958

    
959
let header_libs header =
960
  List.fold_left (fun accu top ->
961
    match top.top_decl_desc with
962
      | ImportedNode nd -> (match nd.nodei_in_lib with 
963
	| None -> accu 
964
	| Some lib -> Utils.list_union [lib] accu)
965
      | _ -> accu 
966
  ) [] header 
967
    
968
let print_makefile basename nodename dependencies fmt =
969
  let compiled_dependencies = 
970
    List.filter (fun (_, _, header) -> header_has_code header) dependencies
971
  in
972
  let lib_dependencies = 
973
    List.fold_left 
974
      (fun accu (_, _, header) -> Utils.list_union (header_libs header) accu) [] dependencies 
975
  in
976
  fprintf fmt "GCC=gcc@.";
977
  fprintf fmt "LUSTREC=%s@." Sys.executable_name;
978
  fprintf fmt "LUSTREC_BASE=%s@." (Filename.dirname (Filename.dirname Sys.executable_name));
979
  fprintf fmt "INC=${LUSTREC_BASE}/include/lustrec@.";
980
  fprintf fmt "@.";
981
  fprintf fmt "%s_%s:@." basename nodename;
982
  fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;    
983
  List.iter (fun s -> (* Format.eprintf "Adding dependency: %s@." s;  *)
984
    fprintf fmt "\t${GCC} -I${INC} -c %s@." s)
985
    (("${INC}/io_frontend.c"):: (* IO functions when a main function is computed *)
986
	(List.map 
987
	   (fun (s, local, _) -> 
988
	     (if local then s else Version.prefix ^ "/include/lustrec/" ^ s) ^ ".c")
989
	   compiled_dependencies));    
990
  fprintf fmt "\t${GCC} -o %s_%s io_frontend.o %a %s.o %a@." basename nodename 
991
    (Utils.fprintf_list ~sep:" " (fun fmt (s, _, _) -> Format.fprintf fmt "%s.o" s)) compiled_dependencies 
992
    basename
993
    (Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib)) lib_dependencies
994
    ;
995
 fprintf fmt "@.";
996
 fprintf fmt "clean:@.";
997
 fprintf fmt "\t\\rm -f *.o %s_%s@." basename nodename
998

    
999

    
1000

    
1001

    
1002
(********************************************************************************************)
1003
(*                         Translation function                                             *)
1004
(********************************************************************************************)
1005

    
1006
let translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename prog machines dependencies =
1007
  (* Generating H file *)
1008

    
1009
  (* Include once: start *)
1010
  let baseNAME = String.uppercase basename in
1011
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
1012
  (* Print the svn version number and the supported C standard (C90 or C99) *)
1013
  print_version header_fmt;
1014
  fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
1015
  pp_print_newline header_fmt ();
1016
  fprintf header_fmt "/* Imports standard library */@.";
1017
  (* imports standard library definitions (arrow) *)
1018
  print_import_standard header_fmt;
1019
  pp_print_newline header_fmt ();
1020
  fprintf header_fmt "/* Types definitions */@.";
1021
  (* Print the type definitions from the type table *)
1022
  print_type_definitions header_fmt basename;
1023
  pp_print_newline header_fmt ();
1024
  (* Print the global constant declarations. *)
1025
  fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
1026
  List.iter (fun c -> print_const_decl header_fmt c) (get_consts prog);
1027
  pp_print_newline header_fmt ();
1028
  (* Print the struct declarations of all machines. *)
1029
  fprintf header_fmt "/* Struct declarations */@.";
1030
  List.iter (print_machine_struct header_fmt) machines;
1031
  pp_print_newline header_fmt ();
1032
  (* Print the prototypes of all machines *)
1033
  fprintf header_fmt "/* Nodes declarations */@.";
1034
  List.iter (print_machine_decl header_fmt) machines;
1035
  pp_print_newline header_fmt ();
1036
  (* Include once: end *)
1037
  fprintf header_fmt "#endif@.";
1038
  pp_print_newline header_fmt ();
1039

    
1040
  (* Generating C file *)
1041

    
1042
  (* If a main node is identified, generate a main function for it *)
1043
  let main_include, main_print, main_makefile =
1044
    match !Options.main_node with
1045
      | "" -> (fun _ -> ()), (fun _ -> ()), (fun _ -> ())
1046
      | main_node -> (
1047
	match Machine_code.get_machine_opt main_node machines with
1048
	| None -> eprintf "Unable to find a main node named %s@.@?" main_node; (fun _ -> ()), (fun _ -> ()), (fun _ -> ())
1049
	| Some m -> print_main_header, print_main_fun machines m, print_makefile basename !Options.main_node dependencies
1050
      )
1051
  in
1052
  main_include source_fmt;
1053
  fprintf source_fmt "#include <stdlib.h>@.#include <assert.h>@.#include \"%s\"@.@." (basename^".h");
1054
  (* Print the svn version number and the supported C standard (C90 or C99) *)
1055
  print_version source_fmt;
1056
  (* Print the prototype of imported nodes *)
1057
  fprintf source_fmt "/* Imported nodes declarations */@.";
1058
  fprintf source_fmt "@[<v>";
1059
  List.iter (print_import_prototype source_fmt) dependencies;
1060
  fprintf source_fmt "@]@.";
1061
  (* Print consts *)
1062
  fprintf source_fmt "/* Global constants (definitions) */@.";
1063
  List.iter (fun c -> print_const_def source_fmt c) (get_consts prog);
1064
  pp_print_newline source_fmt ();
1065
  (* Print nodes one by one (in the previous order) *)
1066
  List.iter (print_machine dependencies source_fmt) machines;
1067
  main_print source_fmt;
1068

    
1069
  (* Generating Makefile *)
1070
  main_makefile makefile_fmt
1071

    
1072
(* Local Variables: *)
1073
(* compile-command:"make -C .." *)
1074
(* End: *)