Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / c_backend.ml @ c02d255e

History | View | Annotate | Download (38.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
let mk_self m =
40
  mk_new_name (m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory) "self"
41

    
42
let mk_call_var_decl loc id =
43
  { var_id = id;
44
    var_dec_type = mktyp Location.dummy_loc Tydec_any;
45
    var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
46
    var_dec_const = false;
47
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
48
    var_clock = Clocks.new_var true;
49
    var_loc = loc }
50

    
51
(* counter for loop variable creation *)
52
let loop_cpt = ref (-1)
53

    
54
let reset_loop_counter () =
55
 loop_cpt := -1
56

    
57
let mk_loop_var m () =
58
  let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in
59
  let rec aux () =
60
    incr loop_cpt;
61
    let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in
62
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
63
  in aux ()
64
(*
65
let addr_cpt = ref (-1)
66

    
67
let reset_addr_counter () =
68
 addr_cpt := -1
69

    
70
let mk_addr_var m var =
71
  let vars = m.mmemory in
72
  let rec aux () =
73
    incr addr_cpt;
74
    let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
75
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
76
  in aux ()
77
*)
78
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
79
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
80
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
81
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
82
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
83
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
84
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
85
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
86

    
87
let pp_c_dimension fmt d =
88
 fprintf fmt "%a" Dimension.pp_dimension d
89

    
90
let pp_c_type var fmt t =
91
  let rec aux t pp_suffix =
92
  match (Types.repr t).Types.tdesc with
93
  | Types.Tclock t'       -> aux t' pp_suffix
94
  | Types.Tbool           -> fprintf fmt "_Bool %s%a" var pp_suffix ()
95
  | Types.Treal           -> fprintf fmt "double %s%a" var pp_suffix ()
96
  | Types.Tint            -> fprintf fmt "int %s%a" var pp_suffix ()
97
  | Types.Tarray (d, t')  ->
98
    let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
99
    aux t' pp_suffix'
100
  | Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
101
  | Types.Tconst ty       -> fprintf fmt "%s %s" ty var
102
  | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var
103
  | _                     -> eprintf "internal error: pp_c_type %a@." Types.print_ty t; assert false
104
  in aux t (fun fmt () -> ())
105

    
106
let rec pp_c_initialize fmt t = 
107
  match (Types.repr t).Types.tdesc with
108
  | Types.Tint -> pp_print_string fmt "0"
109
  | Types.Tclock t' -> pp_c_initialize fmt t'
110
  | Types.Tbool -> pp_print_string fmt "0" 
111
  | Types.Treal -> pp_print_string fmt "0."
112
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
113
    fprintf fmt "{%a}"
114
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
115
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
116
  | _ -> assert false
117

    
118
(* Declaration of an input variable:
119
   - if its type is array/matrix/etc, then declare it as a mere pointer,
120
     in order to cope with unknown/parametric array dimensions, 
121
     as it is the case for generics
122
*)
123
let pp_c_decl_input_var fmt id =
124
  if !Options.ansi && Types.is_array_type id.var_type
125
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
126
  else pp_c_type id.var_id fmt id.var_type
127

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

    
139
(* Declaration of a local/mem variable:
140
   - if it's an array/matrix/etc, its size(s) should be
141
     known in order to statically allocate memory, 
142
     so we print the full type
143
*)
144
let pp_c_decl_local_var fmt id =
145
  pp_c_type id.var_id fmt id.var_type
146

    
147
let pp_c_decl_array_mem self fmt id =
148
  fprintf fmt "%a = (%a) (%s->_reg.%s)"
149
    (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
150
    (pp_c_type "(*)") id.var_type
151
    self
152
    id.var_id
153

    
154
(* Declaration of a struct variable:
155
   - if it's an array/matrix/etc, we declare it as a pointer
156
*)
157
let pp_c_decl_struct_var fmt id =
158
  if Types.is_array_type id.var_type
159
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
160
  else pp_c_type                  id.var_id  fmt id.var_type
161

    
162
(* Access to the value of a variable:
163
   - if it's not a scalar output, then its name is enough
164
   - otherwise, dereference it (it has been declared as a pointer,
165
     despite its scalar Lustre type)
166
   - moreover, cast arrays variables into their original array type.
167
*)
168
let pp_c_var_read m fmt id =
169
  if Types.is_array_type id.var_type
170
  then
171
    fprintf fmt "%s" id.var_id
172
  else
173
    if List.exists (fun o -> o.var_id = id.var_id) m.mstep.step_outputs (* id is output *)
174
    then fprintf fmt "*%s" id.var_id
175
    else fprintf fmt "%s" id.var_id
176

    
177
(* Addressable value of a variable, the one that is passed around in calls:
178
   - if it's not a scalar non-output, then its name is enough
179
   - otherwise, reference it (it must be passed as a pointer,
180
     despite its scalar Lustre type)
181
*)
182
let pp_c_var_write m fmt id =
183
  if Types.is_array_type id.var_type
184
  then
185
    fprintf fmt "%s" id.var_id
186
  else
187
    if List.exists (fun o -> o.var_id = id.var_id) m.mstep.step_outputs (* id is output *)
188
    then
189
      fprintf fmt "%s" id.var_id
190
    else
191
      fprintf fmt "&%s" id.var_id
192

    
193
let pp_c_decl_instance_var fmt (name, (node, static)) = 
194
  fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
195

    
196
let pp_c_tag fmt t =
197
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
198

    
199
(* Prints a constant value *)
200
let rec pp_c_const fmt c =
201
  match c with
202
    | Const_int i    -> pp_print_int fmt i
203
    | Const_real r   -> pp_print_string fmt r
204
    | Const_float r  -> pp_print_float fmt r
205
    | Const_tag t    -> pp_c_tag fmt t
206
    | Const_array ca -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:"," pp_c_const) ca
207

    
208
(* Prints a value expression [v], with internal function calls only.
209
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
210
   but an offset suffix may be added for array variables
211
*)
212
let rec pp_c_val self pp_var fmt v =
213
  match v with
214
    | Cst c         -> pp_c_const fmt c
215
    | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
216
    | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
217
    | Power (v, n)  -> assert false
218
    | LocalVar v    -> pp_var fmt v
219
    | StateVar v    ->
220
      if Types.is_array_type v.var_type
221
      then fprintf fmt "*%a" pp_var v
222
      else fprintf fmt "%s->_reg.%a" self pp_var v
223
    | Fun (n, vl)   -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
224

    
225
let pp_c_checks self fmt m =
226
  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
227

    
228

    
229
(********************************************************************************************)
230
(*                    Instruction Printing functions                                        *)
231
(********************************************************************************************)
232

    
233
(* Computes the depth to which multi-dimension array assignments should be expanded.
234
   It equals the maximum number of nested static array constructions accessible from root [v].
235
*)
236
let rec expansion_depth v =
237
 match v with
238
 | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
239
 | Cst _
240
 | LocalVar _
241
 | StateVar _  -> 0
242
 | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
243
 | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
244
 | Access (v, i) -> max 0 (expansion_depth v - 1)
245
 | Power (v, n)  -> 0 (*1 + expansion_depth v*)
246

    
247
type loop_index = LVar of ident | LInt of int ref
248

    
249
(* Computes the list of nested loop variables together with their dimension bounds.
250
   - LInt r stands for loop expansion (no loop variable, but int loop index)
251
   - LVar v stands for loop variable v
252
*)
253
let rec mk_loop_variables m ty depth =
254
 match (Types.repr ty).Types.tdesc, depth with
255
 | Types.Tarray (d, ty'), 0       ->
256
   let v = mk_loop_var m () in
257
   (d, LVar v) :: mk_loop_variables m ty' 0
258
 | Types.Tarray (d, ty'), _       ->
259
   let r = ref (-1) in
260
   (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
261
 | _                    , 0       -> []
262
 | _                              -> assert false
263

    
264
let reorder_loop_variables loop_vars =
265
  let (int_loops, var_loops) = List.partition (function (d, LInt _) -> true | _ -> false) loop_vars in
266
  var_loops @ int_loops
267

    
268
(* Prints a one loop variable suffix for arrays *)
269
let pp_loop_var fmt lv =
270
 match snd lv with
271
 | LVar v -> fprintf fmt "[%s]" v
272
 | LInt r -> fprintf fmt "[%d]" !r
273

    
274
(* Prints a suffix of loop variables for arrays *)
275
let pp_suffix fmt loop_vars =
276
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
277

    
278
(* Prints a [value] indexed by the suffix list [loop_vars] *)
279
let rec pp_value_suffix self loop_vars pp_value fmt value =
280
 match loop_vars, value with
281
 | (_, LInt r) :: q, Array vl     ->
282
   pp_value_suffix self q pp_value fmt (List.nth vl !r)
283
 | _           :: q, Power (v, n) ->
284
   pp_value_suffix self loop_vars pp_value fmt v
285
 | _               , Fun (n, vl)  ->
286
   Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
287
 | _               , _            ->
288
   let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
289
   pp_c_val self pp_var_suffix fmt value
290

    
291
(* type_directed assignment: array vs. statically sized type
292
   - [var_type]: type of variable to be assigned
293
   - [var_name]: name of variable to be assigned
294
   - [value]: assigned value
295
   - [pp_var]: printer for variables
296
*)
297
let pp_assign m self pp_var fmt var_type var_name value =
298
  let depth = expansion_depth value in
299
(*eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val value depth;*)
300
  let loop_vars = mk_loop_variables m var_type depth in
301
  let reordered_loop_vars = reorder_loop_variables loop_vars in
302
  let rec aux fmt vars =
303
    match vars with
304
    | [] ->
305
      fprintf fmt "%a = %a;" (pp_value_suffix self loop_vars pp_var) var_name (pp_value_suffix self loop_vars pp_var) value
306
    | (d, LVar i) :: q ->
307
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
308
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
309
	i i i Dimension.pp_dimension d i
310
	aux q
311
    | (d, LInt r) :: q ->
312
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
313
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
314
      fprintf fmt "@[<v 2>{@,%a@]@,}"
315
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
316
  in
317
  begin
318
    reset_loop_counter ();
319
    (*reset_addr_counter ();*)
320
    aux fmt reordered_loop_vars
321
  end
322

    
323
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
324
 try (* stateful node instance *)
325
   let (n,_) = List.assoc i m.minstances in
326
   fprintf fmt "%s_step (%a%t%a%t%s->%s);"
327
     (node_name n)
328
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
329
     (Utils.pp_final_char_if_non_empty ", " inputs) 
330
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
331
     (Utils.pp_final_char_if_non_empty ", " outputs)
332
     self
333
     i
334
 with Not_found -> (* stateless node instance *)
335
   let (n,_) = List.assoc i m.mcalls in
336
   fprintf fmt "%s (%a%t%a);"
337
     (node_name n)
338
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
339
     (Utils.pp_final_char_if_non_empty ", " inputs) 
340
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
341

    
342
let pp_machine_reset (m: machine_t) self fmt inst =
343
  let (node, static) = List.assoc inst m.minstances in
344
  fprintf fmt "%a(%a%t%s->%s);"
345
    pp_machine_reset_name (node_name node)
346
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
347
    (Utils.pp_final_char_if_non_empty ", " static)
348
    self inst
349

    
350
let rec pp_conditional (m: machine_t) self fmt c tl el =
351
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
352
    (pp_c_val self (pp_c_var_read m)) c
353
    (Utils.pp_newline_if_non_empty tl)
354
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) tl
355
    (Utils.pp_newline_if_non_empty el)
356
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) el
357

    
358
and pp_machine_instr (m: machine_t) self fmt instr =
359
  match instr with 
360
  | MReset i ->
361
    pp_machine_reset m self fmt i
362
  | MLocalAssign (i,v) ->
363
    pp_assign
364
      m self (pp_c_var_read m) fmt
365
      i.var_type (LocalVar i) v
366
  | MStateAssign (i,v) ->
367
    pp_assign
368
      m self (pp_c_var_read m) fmt
369
      i.var_type (StateVar i) v
370
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
371
    pp_machine_instr m self fmt (MLocalAssign (i0, Fun (i, vl)))
372
  | MStep (il, i, vl) ->
373
    pp_instance_call m self fmt i vl il
374
  | MBranch (g,hl) ->
375
    if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false
376
    then (* boolean case, needs special treatment in C because truth value is not unique *)
377
	 (* may disappear if we optimize code by replacing last branch test with default *)
378
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
379
      let el = try List.assoc tag_false hl with Not_found -> [] in
380
      pp_conditional m self fmt g tl el
381
    else (* enum type case *)
382
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
383
	(pp_c_val self (pp_c_var_read m)) g
384
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch m self)) hl
385

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

    
389

    
390
(**************************************************************************)
391
(*     Printing spec for c *)
392

    
393
(**************************************************************************)
394

    
395

    
396
let pp_econst fmt c = 
397
  match c with
398
    | EConst_int i -> pp_print_int fmt i
399
    | EConst_real r -> pp_print_string fmt r
400
    | EConst_float r -> pp_print_float fmt r
401
    | EConst_bool b -> pp_print_bool fmt b
402
    | EConst_string s -> pp_print_string fmt ("\"" ^ s ^ "\"")
403

    
404
let rec pp_eexpr is_output fmt eexpr = 
405
  let pp_eexpr = pp_eexpr is_output in
406
  match eexpr.eexpr_desc with
407
    | EExpr_const c -> pp_econst fmt c
408
    | EExpr_ident id -> 
409
      if is_output id then pp_print_string fmt ("*" ^ id) else pp_print_string fmt id
410
    | EExpr_tuple el -> Utils.fprintf_list ~sep:"," pp_eexpr fmt el
411
    | EExpr_arrow (e1, e2) -> fprintf fmt "%a -> %a" pp_eexpr e1 pp_eexpr e2
412
    | EExpr_fby (e1, e2) -> fprintf fmt "%a fby %a" pp_eexpr e1 pp_eexpr e2
413
    (* | EExpr_concat (e1, e2) -> fprintf fmt "%a::%a" pp_eexpr e1 pp_eexpr e2 *)
414
    (* | EExpr_tail e -> fprintf fmt "tail %a" pp_eexpr e *)
415
    | EExpr_pre e -> fprintf fmt "pre %a" pp_eexpr e
416
    | EExpr_when (e, id) -> fprintf fmt "%a when %s" pp_eexpr e id
417
    | EExpr_merge (id, e1, e2) -> 
418
      fprintf fmt "merge (%s, %a, %a)" id pp_eexpr e1 pp_eexpr e2
419
    | EExpr_appl (id, e, r) -> pp_eapp is_output fmt id e r
420
    | EExpr_forall (vars, e) -> fprintf fmt "forall %a; %a" Printers.pp_node_args vars pp_eexpr e 
421
    | EExpr_exists (vars, e) -> fprintf fmt "exists %a; %a" Printers.pp_node_args vars pp_eexpr e 
422

    
423

    
424
    (* | EExpr_whennot _ *)
425
    (* | EExpr_uclock _ *)
426
    (* | EExpr_dclock _ *)
427
    (* | EExpr_phclock _ -> assert false *)
428
and pp_eapp is_output fmt id e r =
429
  let pp_eexpr = pp_eexpr is_output in
430
  match r with
431
  | None ->
432
    (match id, e.eexpr_desc with
433
    | "+", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a + %a)" pp_eexpr e1 pp_eexpr e2
434
    | "uminus", _ -> fprintf fmt "(- %a)" pp_eexpr e
435
    | "-", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a - %a)" pp_eexpr e1 pp_eexpr e2
436
    | "*", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a * %a)" pp_eexpr e1 pp_eexpr e2
437
    | "/", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a / %a)" pp_eexpr e1 pp_eexpr e2
438
    | "mod", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a mod %a)" pp_eexpr e1 pp_eexpr e2
439
    | "&&", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a && %a)" pp_eexpr e1 pp_eexpr e2
440
    | "||", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a || %a)" pp_eexpr e1 pp_eexpr e2
441
    | "xor", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a ^^ %a)" pp_eexpr e1 pp_eexpr e2
442
    | "impl", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a ==> %a)" pp_eexpr e1 pp_eexpr e2
443
    | "<", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a < %a)" pp_eexpr e1 pp_eexpr e2
444
    | "<=", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a <= %a)" pp_eexpr e1 pp_eexpr e2
445
    | ">", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a > %a)" pp_eexpr e1 pp_eexpr e2
446
    | ">=", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a >= %a)" pp_eexpr e1 pp_eexpr e2
447
    | "!=", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a != %a)" pp_eexpr e1 pp_eexpr e2
448
    | "=", EExpr_tuple([e1;e2]) -> fprintf fmt "(%a == %a)" pp_eexpr e1 pp_eexpr e2
449
    | "not", _ -> fprintf fmt "(! %a)" pp_eexpr e
450
    | "ite", EExpr_tuple([e1;e2;e3]) -> fprintf fmt "(if %a then %a else %a)" pp_eexpr e1 pp_eexpr e2 pp_eexpr e3
451
    | _ -> fprintf fmt "%s (%a)" id pp_eexpr e)
452
  | Some x -> fprintf fmt "%s (%a) every %s" id pp_eexpr e x 
453

    
454
let pp_ensures is_output fmt e =
455
  match e with
456
    | EnsuresExpr e -> fprintf fmt "ensures %a;@ " (pp_eexpr is_output) e
457
    | SpecObserverNode (name, args) -> fprintf fmt "observer %s (%a);@ " name (Utils.fprintf_list ~sep:", " (pp_eexpr is_output)) args
458

    
459
let pp_acsl_spec outputs fmt spec =
460
  let is_output = fun oid -> List.exists (fun v -> v.var_id = oid) outputs in
461
  let pp_eexpr = pp_eexpr is_output in
462
  fprintf fmt "@[<v 2>/*@@ ";
463
  Utils.fprintf_list ~sep:"" (fun fmt r -> fprintf fmt "requires %a;@ " pp_eexpr r) fmt spec.requires;
464
  Utils.fprintf_list ~sep:"" (pp_ensures is_output) fmt spec.ensures;
465
  fprintf fmt "@ ";
466
  (* fprintf fmt "assigns *self%t%a;@ "  *)
467
  (*   (fun fmt -> if List.length outputs > 0 then fprintf fmt ", ") *)
468
  (*   (fprintf_list ~sep:"," (fun fmt v -> fprintf fmt "*%s" v.var_id)) outputs; *)
469
  Utils.fprintf_list ~sep:"@ " (fun fmt (name, assumes, requires) -> 
470
    fprintf fmt "behavior %s:@[@ %a@ %a@]" 
471
      name
472
      (Utils.fprintf_list ~sep:"@ " (fun fmt r -> fprintf fmt "assumes %a;" pp_eexpr r)) assumes
473
      (Utils.fprintf_list ~sep:"@ " (pp_ensures is_output)) requires
474
  ) fmt spec.behaviors;
475
  fprintf fmt "@]@ */@.";
476
  ()
477

    
478
(********************************************************************************************)
479
(*                      Prototype Printing functions                                        *)
480
(********************************************************************************************)
481

    
482
let print_alloc_prototype fmt (name, static) =
483
  fprintf fmt "%a * %a (%a)"
484
    pp_machine_memtype_name name
485
    pp_machine_alloc_name name
486
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
487

    
488
let print_reset_prototype self fmt (name, static) =
489
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
490
    pp_machine_reset_name name
491
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
492
    (Utils.pp_final_char_if_non_empty ",@," static) 
493
    pp_machine_memtype_name name
494
    self
495

    
496
let print_stateless_prototype fmt (name, inputs, outputs) =
497
match outputs with
498
(* DOESN'T WORK FOR ARRAYS
499
  | [o] -> fprintf fmt "%a (@[<v>%a@])"
500
    (pp_c_type name) o.var_type
501
    (Utils.fprintf_list ~sep:",@ " pp_c_var) inputs
502
*)  
503
  | _ -> fprintf fmt "void %s (@[<v>@[%a%t@]@,@[%a@]@,@])"
504
    name
505
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
506
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
507
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
508

    
509
let print_step_prototype self fmt (name, inputs, outputs) =
510
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
511
    pp_machine_step_name name
512
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
513
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
514
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
515
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
516
    pp_machine_memtype_name name
517
    self
518

    
519
(********************************************************************************************)
520
(*                         Header Printing functions                                        *)
521
(********************************************************************************************)
522

    
523
(* Removed because of "open" constructs. No more extern functions *)
524
(*
525
let print_prototype fmt decl =
526
  match decl.top_decl_desc with
527
    | ImportedFun m -> (
528
        fprintf fmt "extern %a;@,"
529
	  print_stateless_prototype 
530
	  (m.fun_id, m.fun_inputs, m.fun_outputs)
531
    )
532
    | ImportedNode m -> (
533
      if m.nodei_stateless then (* It's a function not a node *)
534
        fprintf fmt "extern %a;@,"
535
	  print_stateless_prototype 
536
	  (m.nodei_id, m.nodei_inputs, m.nodei_outputs)
537
      else (
538
	let static = List.filter (fun v -> v.var_dec_const) m.nodei_inputs in
539
        fprintf fmt "extern %a;@,"
540
	  print_alloc_prototype (m.nodei_id, static);
541
	fprintf fmt "extern %a;@,"
542
	  (print_reset_prototype "self") (m.nodei_id, static);
543
	fprintf fmt "extern %a;@,"
544
	  (print_step_prototype "self") (m.nodei_id, m.nodei_inputs, m.nodei_outputs);
545
      )
546
    )
547
    | _ -> () (* We don't do anything here *)
548
      *)
549

    
550
let print_prototype fmt decl =
551
  match decl.top_decl_desc with
552
  | Open m -> fprintf fmt "#include \"%s.h\"@," m
553
  | _ -> () (* We don't do anything here *)
554
    
555
let pp_registers_struct fmt m =
556
  if m.mmemory <> []
557
  then
558
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
559
      pp_machine_regtype_name m.mname.node_id
560
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
561
  else
562
    ()
563

    
564
let print_machine_struct fmt m =
565
  (* Define struct *)
566
  fprintf fmt "@[%a {@[%a%a%t@]};@]@."
567
    pp_machine_memtype_name m.mname.node_id
568
    pp_registers_struct m
569
    (Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
570
    (Utils.pp_final_char_if_non_empty "; " m.minstances) 
571
(*
572
let pp_static_array_instance fmt m (v, m) =
573
 fprintf fmt "%s" (mk_addr_var m v)
574
*)
575
let print_static_declare_instance fmt (i, (m, static)) =
576
  fprintf fmt "%a(%a%t%s)"
577
    pp_machine_static_declare_name (node_name m)
578
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
579
    (Utils.pp_final_char_if_non_empty ", " static)
580
    i
581

    
582
let print_static_declare_macro fmt m =
583
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
584
  fprintf fmt "@[<v 2>#define %a(%a%tinst)\\@,%a inst;\\@,%a%t%a;@,@]"
585
    pp_machine_static_declare_name m.mname.node_id
586
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
587
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
588
    pp_machine_memtype_name m.mname.node_id
589
    (Utils.fprintf_list ~sep:";\\@," pp_c_decl_local_var) array_mem
590
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
591
    (Utils.fprintf_list ~sep:";\\@,"
592
       (fun fmt (i',m') ->
593
	 let path = sprintf "inst ## _%s" i' in
594
	 fprintf fmt "%a"
595
	   print_static_declare_instance (path,m')
596
       )) m.minstances
597

    
598
      
599
let print_static_link_instance fmt (i, (m, _)) =
600
 fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
601

    
602
let print_static_link_macro fmt m =
603
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
604
  fprintf fmt "@[<v>@[<v 2>#define %a(inst) do {\\@,%a%t%a;\\@]@,} while (0)@.@]"
605
    pp_machine_static_link_name m.mname.node_id
606
    (Utils.fprintf_list ~sep:";\\@,"
607
       (fun fmt v ->
608
	 fprintf fmt "inst.%s = &%s"
609
	   v.var_id
610
	   v.var_id
611
       )) array_mem
612
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
613
    (Utils.fprintf_list ~sep:";\\@,"
614
       (fun fmt (i',m') ->
615
	 let path = sprintf "inst ## _%s" i' in
616
	 fprintf fmt "%a;\\@,inst.%s = &%s"
617
	   print_static_link_instance (path,m')
618
	   i'
619
	   path
620
       )) m.minstances
621
      
622
let print_static_alloc_macro fmt m =
623
  fprintf fmt "@[<v>@[<v 2>#define %a(%a%tinst)\\@,%a(%a%tinst);\\@,%a(inst);@]@,@]@."
624
    pp_machine_static_alloc_name m.mname.node_id
625
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
626
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
627
    pp_machine_static_declare_name m.mname.node_id
628
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
629
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
630
    pp_machine_static_link_name m.mname.node_id
631

    
632
let print_machine_decl fmt m =
633
  (* Static allocation *)
634
  if !Options.static_mem then (
635
  fprintf fmt "%a@.%a@.%a@."
636
    print_static_declare_macro m
637
    print_static_link_macro m
638
    print_static_alloc_macro m;
639
  )
640
  else ( 
641
    (* Dynamic allocation *)
642
    fprintf fmt "extern %a;@.@."
643
      print_alloc_prototype (m.mname.node_id, m.mstatic);
644
  );
645
  if m.mname.node_id = arrow_id then (
646
  (* Arrow will be defined by a #define macro because of polymorphism *)
647
    fprintf fmt "#define _arrow_step(x,y,output,self) ((self)->_reg._first?((self)->_reg._first=0,(*output = x)):(*output = y))@.@.";
648
    fprintf fmt "#define _arrow_reset(self) {(self)->_reg._first = 1;}@.@."
649
  )
650
  else (
651
    let self = mk_self m in
652
    fprintf fmt "extern %a;@.@."
653
      (print_reset_prototype self) (m.mname.node_id, m.mstatic);
654
    (* Print specification if any *)
655
    (match m.mspec with
656
      | None -> ()
657
      | Some spec -> 
658
	pp_acsl_spec m.mstep.step_outputs fmt spec
659
    );
660
    fprintf fmt "extern %a;@.@."
661
      (print_step_prototype self)
662
      (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
663
  )
664

    
665

    
666
(********************************************************************************************)
667
(*                         C file Printing functions                                        *)
668
(********************************************************************************************)
669

    
670
let print_const fmt cdecl =
671
  fprintf fmt "%a = %a;@." (pp_c_type cdecl.const_id) cdecl.const_type pp_c_const cdecl.const_value 
672

    
673
let print_alloc_instance fmt (i, (m, static)) =
674
  fprintf fmt "_alloc->%s = %a (%a);@,"
675
    i
676
    pp_machine_alloc_name (node_name m)
677
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
678

    
679
let print_alloc_array fmt vdecl =
680
  let base_type = Types.array_base_type vdecl.var_type in
681
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
682
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
683
  fprintf fmt "_alloc->%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
684
    vdecl.var_id
685
    (pp_c_type "") base_type
686
    Dimension.pp_dimension size_type
687
    (pp_c_type "") base_type
688
    vdecl.var_id
689

    
690
let print_alloc_code fmt m =
691
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
692
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
693
    pp_machine_memtype_name m.mname.node_id
694
    pp_machine_memtype_name m.mname.node_id
695
    pp_machine_memtype_name m.mname.node_id
696
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
697
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
698

    
699
let print_step_code fmt m self =
700
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
701
  then
702
    (* C99 code *)
703
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
704
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@."
705
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
706
      (* locals *)
707
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
708
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
709
      (* array mems *)
710
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
711
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
712
      (* check assertions *)
713
      (pp_c_checks self) m
714
      (* instrs *)
715
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) m.mstep.step_instrs
716
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
717
      (fun fmt -> fprintf fmt "return;")
718
  else
719
    (* C90 code *)
720
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
721
    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
722
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
723
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
724
      (* locals *)
725
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
726
      (Utils.pp_final_char_if_non_empty ";" base_locals)
727
      (* check assertions *)
728
      (pp_c_checks self) m
729
      (* instrs *)
730
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) m.mstep.step_instrs
731
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
732
      (fun fmt -> fprintf fmt "return;")
733

    
734
let print_machine fmt m =
735
  (* Alloc function, only if non static mode *)
736
  if (not !Options.static_mem) then  
737
    (
738
      fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@."
739
	print_alloc_prototype (m.mname.node_id, m.mstatic)
740
	print_alloc_code m;
741
    );
742
  if m.mname.node_id = arrow_id then () else ( (* We don't print arrow function *)
743
    let self = mk_self m in
744
    (* Reset function *)
745
    fprintf fmt "@[<v 2>%a {@,%a%treturn;@]@,}@.@."
746
      (print_reset_prototype self) (m.mname.node_id, m.mstatic)
747
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) m.minit
748
      (Utils.pp_newline_if_non_empty m.minit);
749
    (* Step function *)
750
    print_step_code fmt m self
751
  )
752

    
753
(********************************************************************************************)
754
(*                         Main related functions                                           *)
755
(********************************************************************************************)
756

    
757
let print_get_input fmt v =
758
  match v.var_type.Types.tdesc with
759
    | Types.Tint -> fprintf fmt "_get_int(\"%s\")" v.var_id
760
    | Types.Tbool -> fprintf fmt "_get_bool(\"%s\")" v.var_id
761
    | Types.Treal -> fprintf fmt "_get_double(\"%s\")" v.var_id
762
    | _ -> assert false
763

    
764
let print_put_outputs fmt ol = 
765
  let po fmt o =
766
    match o.var_type.Types.tdesc with
767
    | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id
768
    | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id
769
    | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id
770
    | _ -> assert false
771
  in
772
  List.iter (fprintf fmt "@ %a;" po) ol
773

    
774
let print_main_fun machines m fmt =
775
  let mname = m.mname.node_id in
776
  let main_mem =
777
    if (!Options.static_mem && !Options.main_node <> "")
778
    then "&main_mem"
779
    else "main_mem" in
780
  fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ ";
781
  fprintf fmt "/* Declaration of inputs/outputs variables */@ ";
782
  List.iter 
783
    (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type pp_c_initialize v.var_type
784
    ) m.mstep.step_inputs;
785
  List.iter 
786
    (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type pp_c_initialize v.var_type
787
    ) m.mstep.step_outputs;
788
  fprintf fmt "@ /* Main memory allocation */@ ";
789
  if (!Options.static_mem && !Options.main_node <> "")
790
  then (fprintf fmt "%a(main_mem);@ " pp_machine_static_alloc_name mname)
791
  else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname);
792
  fprintf fmt "@ /* Initialize the main memory */@ ";
793
  fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem;
794
  fprintf fmt "@ ISATTY = isatty(0);@ ";
795
  fprintf fmt "@ /* Infinite loop */@ ";
796
  fprintf fmt "@[<v 2>while(1){@ ";
797
  fprintf fmt  "fflush(stdout);@ ";
798
  List.iter 
799
    (fun v -> fprintf fmt "%s = %a;@ "
800
      v.var_id
801
      print_get_input v
802
    ) m.mstep.step_inputs;
803
  (match m.mstep.step_outputs with
804
    (* | [] -> ( *)
805
    (*   fprintf fmt "%a(%a%t%s);@ "  *)
806
    (* 	pp_machine_step_name mname *)
807
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
808
    (* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
809
    (* 	main_mem *)
810
    (* ) *)
811
    (* | [o] -> ( *)
812
    (*   fprintf fmt "%s = %a(%a%t%a, %s);%a" *)
813
    (* 	o.var_id *)
814
    (* 	pp_machine_step_name mname *)
815
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
816
    (* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
817
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)
818
    (* 	main_mem *)
819
    (* 	print_put_outputs [o]) *)
820
    | _ -> (
821
      fprintf fmt "%a(%a%t%a, %s);%a"
822
	pp_machine_step_name mname
823
	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs
824
	(Utils.pp_final_char_if_non_empty ", " m.mstep.step_inputs)
825
	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs
826
	main_mem
827
	print_put_outputs m.mstep.step_outputs)
828
  );
829
  fprintf fmt "@]@ }@ ";
830
  fprintf fmt "return 1;";
831
  fprintf fmt "@]@ }@."       
832

    
833
let print_main_header fmt =
834
  fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"io_frontend.h\"@."
835

    
836
let rec pp_c_type_decl cpt var fmt tdecl =
837
  match tdecl with
838
  | Tydec_any           -> assert false
839
  | Tydec_int           -> fprintf fmt "int %s" var
840
  | Tydec_real          -> fprintf fmt "double %s" var
841
  | Tydec_float         -> fprintf fmt "float %s" var
842
  | Tydec_bool          -> fprintf fmt "_Bool %s" var
843
  | Tydec_clock ty      -> pp_c_type_decl cpt var fmt ty
844
  | Tydec_const c       -> fprintf fmt "%s %s" c var
845
  | Tydec_array (d, ty) -> fprintf fmt "%a[%a]" (pp_c_type_decl cpt var) ty pp_c_dimension d
846
  | Tydec_enum tl ->
847
    begin
848
      incr cpt;
849
      fprintf fmt "enum _enum_%d { %a } %s" !cpt (Utils.fprintf_list ~sep:", " pp_print_string) tl var
850
    end
851

    
852
let print_type_definitions fmt =
853
  let cpt_type = ref 0 in
854
  Hashtbl.iter (fun typ def ->
855
    match typ with
856
    | Tydec_const var ->
857
      fprintf fmt "typedef %a;@.@."
858
	(pp_c_type_decl cpt_type var) def
859
    | _        -> ()) type_table
860

    
861
let print_makefile basename nodename fmt =
862
  fprintf fmt "GCC=gcc@.";
863
  fprintf fmt "LUSTREC=%s@." Sys.executable_name;
864
  fprintf fmt "LUSTREC_BASE=%s@." (Filename.dirname (Filename.dirname Sys.executable_name));
865
  fprintf fmt "INC=${LUSTREC_BASE}/include/lustrec@.";
866
  fprintf fmt "@.";
867
  fprintf fmt "%s_%s:@." basename nodename;
868
  fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;    
869
  fprintf fmt "\t${GCC} -I${INC} -c ${INC}/io_frontend.c@.";    
870
(*  fprintf fmt "\t${GCC} -I${INC} -c ${INC}/StdLibrary.c@."; *)
871
(*  fprintf fmt "\t${GCC} -o %s_%s io_frontend.o StdLibrary.o -lm %s.o@." basename nodename basename*)
872
 fprintf fmt "\t${GCC} -o %s_%s io_frontend.o -lm %s.o@." basename nodename basename;
873
 fprintf fmt "@.";
874
 fprintf fmt "clean:@.";
875
 fprintf fmt "\t\\rm -f *.o %s_%s@." basename nodename
876

    
877

    
878

    
879
(********************************************************************************************)
880
(*                         Translation function                                             *)
881
(********************************************************************************************)
882
    
883
let translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename prog machines =
884
  (* Generating H file *)
885

    
886
  (* Include once: start *)
887
  let baseNAME = String.uppercase basename in
888
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
889
  (* Print the svn version number and the supported C standard (C90 or C99) *)
890
  print_version header_fmt;
891
  fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
892
(*
893
  let machine_iter = compute_dep_machines machines in
894
*)
895
  (* Print the struct of all machines. This need to be done following the good
896
     order. *)
897
  fprintf header_fmt "/* Struct declarations */@.";
898
  List.iter (print_machine_struct header_fmt) machines;
899
  pp_print_newline header_fmt ();
900

    
901
  (* Print the prototypes of all machines *)
902
  fprintf header_fmt "/* Nodes declarations */@.";
903
  List.iter (print_machine_decl header_fmt) machines;
904
  pp_print_newline header_fmt ();
905
  (* Include once: end *)
906
  fprintf header_fmt "#endif@.";
907
  pp_print_newline header_fmt ();
908

    
909
  (* Generating C file *)
910
  
911
  (* If a main node is identified, generate a main function for it *)
912
  let main_include, main_print, main_makefile =
913
    match !Options.main_node with
914
      | "" -> (fun _ -> ()), (fun _ -> ()), (fun _ -> ())
915
      | main_node -> ( 
916
	let main_node_opt = 
917
	  List.fold_left 
918
	  (fun res m -> 
919
	    match res with 
920
	      | Some _ -> res 
921
	      | None -> if m.mname.node_id = main_node then Some m else None)
922
	  None machines
923
      in 
924
      match main_node_opt with
925
	| None -> eprintf "Unable to find a main node named %s@.@?" main_node; (fun _ -> ()), (fun _ -> ()), (fun _ -> ())
926
	| Some m -> print_main_header, print_main_fun machines m, print_makefile basename !Options.main_node
927
    )
928
  in
929
  main_include source_fmt;
930
  fprintf source_fmt "#include <stdlib.h>@.#include <assert.h>@.#include \"%s\"@.@." (basename^".h");
931
  (* Print the svn version number and the supported C standard (C90 or C99) *)
932
  print_version source_fmt;
933
  (* Print the prototype of imported nodes *)
934
  fprintf source_fmt "/* Imported nodes declarations */@.";
935
  fprintf source_fmt "@[<v>";
936
  List.iter (print_prototype source_fmt) prog;
937
  fprintf source_fmt "@]@.";
938
  (* Print the type definitions from the type table *)
939
  print_type_definitions source_fmt;
940
  (* Print consts *)
941
  fprintf source_fmt "/* Global constants */@.";
942
  List.iter (fun c -> print_const source_fmt c) (get_consts prog); 
943
  pp_print_newline source_fmt ();
944
  (* Print nodes one by one (in the previous order) *)
945
  List.iter (print_machine source_fmt) machines;
946
  main_print source_fmt;
947

    
948
  (* Generating Makefile *)
949
  main_makefile makefile_fmt    
950

    
951
(* Local Variables: *)
952
(* compile-command:"make -C .." *)
953
(* End: *)