Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_common.ml @ 521e2a6b

History | View | Annotate | Download (24.1 KB)

1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

    
12
open Format
13
open LustreSpec
14
open Corelang
15
open Machine_code
16

    
17

    
18
let print_version fmt =
19
  Format.fprintf fmt 
20
    "/* @[<v>C code generated by %s@,Version number %s@,Code is %s compliant@,Using %s numbers */@,@]@."
21
    (Filename.basename Sys.executable_name) 
22
    Version.number 
23
    (if !Options.ansi then "ANSI C90" else "C99")
24
    (if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point")
25

    
26
let file_to_module_name basename =
27
  let baseNAME = String.uppercase_ascii basename in
28
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
29
  baseNAME
30

    
31
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
32
let mk_self m =
33
  let used name =
34
       (List.exists (fun v -> v.var_id = name) m.mstep.step_inputs)
35
    || (List.exists (fun v -> v.var_id = name) m.mstep.step_outputs)
36
    || (List.exists (fun v -> v.var_id = name) m.mstep.step_locals)
37
    || (List.exists (fun v -> v.var_id = name) m.mmemory) in
38
  mk_new_name used "self"
39

    
40
(* Generation of a non-clashing name for the instance variable of static allocation macro *)
41
let mk_instance m =
42
  let used name =
43
       (List.exists (fun v -> v.var_id = name) m.mstep.step_inputs)
44
    || (List.exists (fun v -> v.var_id = name) m.mmemory) in
45
  mk_new_name used "inst"
46

    
47
(* Generation of a non-clashing name for the attribute variable of static allocation macro *)
48
let mk_attribute m =
49
  let used name =
50
       (List.exists (fun v -> v.var_id = name) m.mstep.step_inputs)
51
    || (List.exists (fun v -> v.var_id = name) m.mmemory) in
52
  mk_new_name used "attr"
53

    
54
let mk_call_var_decl loc id =
55
  { var_id = id;
56
    var_orig = false;
57
    var_dec_type = mktyp Location.dummy_loc Tydec_any;
58
    var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
59
    var_dec_const = false;
60
    var_dec_value = None;
61
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
62
    var_clock = Clocks.new_var true;
63
    var_loc = loc }
64

    
65
(* counter for loop variable creation *)
66
let loop_cpt = ref (-1)
67

    
68
let reset_loop_counter () =
69
 loop_cpt := -1
70

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

    
81
let reset_addr_counter () =
82
 addr_cpt := -1
83

    
84
let mk_addr_var m var =
85
  let vars = m.mmemory in
86
  let rec aux () =
87
    incr addr_cpt;
88
    let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
89
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
90
  in aux ()
91
*)
92
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id
93
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
94
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
95
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
96
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
97
let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id
98
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
99
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
100
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
101
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
102
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
103
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
104
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
105

    
106
let rec pp_c_dimension fmt dim =
107
  match dim.Dimension.dim_desc with
108
  | Dimension.Dident id       ->
109
    fprintf fmt "%s" id
110
  | Dimension.Dint i          ->
111
    fprintf fmt "%d" i
112
  | Dimension.Dbool b         ->
113
    fprintf fmt "%B" b
114
  | Dimension.Dite (i, t, e)  ->
115
    fprintf fmt "((%a)?%a:%a)"
116
       pp_c_dimension i pp_c_dimension t pp_c_dimension e
117
 | Dimension.Dappl (f, args) ->
118
     fprintf fmt "%a" (Basic_library.pp_c f pp_c_dimension) args
119
 | Dimension.Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim'
120
 | Dimension.Dvar       -> fprintf fmt "_%s" (Utils.name_of_dimension dim.Dimension.dim_id)
121
 | Dimension.Dunivar    -> fprintf fmt "'%s" (Utils.name_of_dimension dim.Dimension.dim_id)
122

    
123
let is_basic_c_type t =
124
  match (Types.repr t).Types.tdesc with
125
  | Types.Tbool | Types.Treal | Types.Tint  -> true
126
  | _                                       -> false
127

    
128
let pp_c_basic_type_desc t_dsec =
129
  match t_dsec with
130
  | Types.Tbool when !Options.cpp  -> "bool"
131
  | Types.Tbool                    -> "_Bool"
132
  | Types.Tint                     -> !Options.int_type
133
  | Types.Treal when !Options.mpfr -> Mpfr.mpfr_t
134
  | Types.Treal                    -> !Options.real_type
135
  | _ -> assert false (* Not a basic C type. Do not handle arrays or pointers *)
136

    
137
let pp_basic_c_type fmt t = fprintf fmt "%s" (pp_c_basic_type_desc (Types.repr t).Types.tdesc)
138

    
139
let pp_c_type var fmt t =
140
  let rec aux t pp_suffix =
141
    match (Types.repr t).Types.tdesc with
142
    | Types.Tclock t'       -> aux t' pp_suffix
143
    | Types.Tbool | Types.Tint | Types.Treal
144
                            -> fprintf fmt "%a %s%a" pp_basic_c_type t var pp_suffix ()
145
    | Types.Tarray (d, t')  ->
146
      let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
147
      aux t' pp_suffix'
148
    | Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
149
    | Types.Tconst ty       -> fprintf fmt "%s %s" ty var
150
    | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var
151
    | _                     -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false
152
  in aux t (fun fmt () -> ())
153
(*
154
let rec pp_c_initialize fmt t = 
155
  match (Types.repr t).Types.tdesc with
156
  | Types.Tint -> pp_print_string fmt "0"
157
  | Types.Tclock t' -> pp_c_initialize fmt t'
158
  | Types.Tbool -> pp_print_string fmt "0" 
159
  | Types.Treal when not !Options.mpfr -> pp_print_string fmt "0."
160
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
161
    fprintf fmt "{%a}"
162
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
163
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
164
  | _ -> assert false
165
 *)
166
let pp_c_tag fmt t =
167
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
168

    
169

    
170
(* Prints a constant value *)
171
let rec pp_c_const fmt c =
172
  match c with
173
    | Const_int i     -> pp_print_int fmt i
174
    | Const_real (c,e,s)-> pp_print_string fmt s (* Format.fprintf fmt "%ie%i" c e*)
175
    (* | Const_float r   -> pp_print_float fmt r *)
176
    | Const_tag t     -> pp_c_tag fmt t
177
    | Const_array ca  -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
178
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
179
    | Const_string _ -> assert false (* string occurs in annotations not in C *)
180

    
181
(* Prints a value expression [v], with internal function calls only.
182
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
183
   but an offset suffix may be added for array variables
184
*)
185
let rec pp_c_val self pp_var fmt v =
186
  match v.value_desc with
187
  | Cst c         -> pp_c_const fmt c
188
  | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
189
  | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
190
  | Power (v, n)  -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false)
191
  | LocalVar v    -> pp_var fmt v
192
  | StateVar v    ->
193
    (* array memory vars are represented by an indirection to a local var with the right type,
194
       in order to avoid casting everywhere. *)
195
    if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr)
196
    then fprintf fmt "%a" pp_var v
197
    else fprintf fmt "%s->_reg.%a" self pp_var v
198
  | Fun (n, vl)   -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
199

    
200
(* Access to the value of a variable:
201
   - if it's not a scalar output, then its name is enough
202
   - otherwise, dereference it (it has been declared as a pointer,
203
     despite its scalar Lustre type)
204
   - moreover, dereference memory array variables.
205
*)
206
let pp_c_var_read m fmt id =
207
  (* mpfr_t is a static array, not treated as general arrays *)
208
  if Types.is_address_type id.var_type
209
  then
210
    if is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr)
211
    then fprintf fmt "(*%s)" id.var_id
212
    else fprintf fmt "%s" id.var_id
213
  else
214
    if is_output m id
215
    then fprintf fmt "*%s" id.var_id
216
    else fprintf fmt "%s" id.var_id
217

    
218
(* Addressable value of a variable, the one that is passed around in calls:
219
   - if it's not a scalar non-output, then its name is enough
220
   - otherwise, reference it (it must be passed as a pointer,
221
     despite its scalar Lustre type)
222
*)
223
let pp_c_var_write m fmt id =
224
  if Types.is_address_type id.var_type
225
  then
226
    fprintf fmt "%s" id.var_id
227
  else
228
    if is_output m id
229
    then
230
      fprintf fmt "%s" id.var_id
231
    else
232
      fprintf fmt "&%s" id.var_id
233

    
234
(* Declaration of an input variable:
235
   - if its type is array/matrix/etc, then declare it as a mere pointer,
236
     in order to cope with unknown/parametric array dimensions, 
237
     as it is the case for generics
238
*)
239
let pp_c_decl_input_var fmt id =
240
  if !Options.ansi && Types.is_address_type id.var_type
241
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
242
  else pp_c_type id.var_id fmt id.var_type
243

    
244
(* Declaration of an output variable:
245
   - if its type is scalar, then pass its address
246
   - if its type is array/matrix/struct/etc, then declare it as a mere pointer,
247
     in order to cope with unknown/parametric array dimensions, 
248
     as it is the case for generics
249
*)
250
let pp_c_decl_output_var fmt id =
251
  if (not !Options.ansi) && Types.is_address_type id.var_type
252
  then pp_c_type                  id.var_id  fmt id.var_type
253
  else pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
254

    
255
(* Declaration of a local/mem variable:
256
   - if it's an array/matrix/etc, its size(s) should be
257
     known in order to statically allocate memory, 
258
     so we print the full type
259
*)
260
let pp_c_decl_local_var m fmt id =
261
  if id.var_dec_const
262
  then
263
    Format.fprintf fmt "%a = %a"
264
      (pp_c_type id.var_id) id.var_type
265
      (pp_c_val "" (pp_c_var_read m)) (get_const_assign m id)
266
  else
267
    Format.fprintf fmt "%a"
268
      (pp_c_type id.var_id) id.var_type
269

    
270
let pp_c_decl_array_mem self fmt id =
271
  fprintf fmt "%a = (%a) (%s->_reg.%s)"
272
    (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
273
    (pp_c_type "(*)") id.var_type
274
    self
275
    id.var_id
276

    
277
(* Declaration of a struct variable:
278
   - if it's an array/matrix/etc, we declare it as a pointer
279
*)
280
let pp_c_decl_struct_var fmt id =
281
  if Types.is_array_type id.var_type
282
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
283
  else pp_c_type                  id.var_id  fmt id.var_type
284

    
285
let pp_c_decl_instance_var fmt (name, (node, static)) = 
286
  fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
287

    
288
let pp_c_checks self fmt m =
289
  Utils.fprintf_list ~sep:"" 
290
    (fun fmt (loc, check) -> 
291
      fprintf fmt 
292
	"@[<v>%a@,assert (%a);@]@," 
293
	Location.pp_c_loc loc
294
	(pp_c_val self (pp_c_var_read m)) check
295
    ) 
296
    fmt 
297
    m.mstep.step_checks
298

    
299
(********************************************************************************************)
300
(*                       Struct Printing functions                                          *)
301
(********************************************************************************************)
302

    
303
let pp_registers_struct fmt m =
304
  if m.mmemory <> []
305
  then
306
    fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; "
307
      pp_machine_regtype_name m.mname.node_id
308
      (Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory
309
  else
310
    ()
311

    
312
let print_machine_struct fmt m =
313
  if fst (get_stateless_status m) then
314
    begin
315
    end
316
  else
317
    begin
318
      (* Define struct *)
319
      fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."
320
	pp_machine_memtype_name m.mname.node_id
321
	pp_registers_struct m
322
	(Utils.pp_final_char_if_non_empty "@ " m.mmemory)
323
	(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances
324
	(Utils.pp_final_char_if_non_empty ";@ " m.minstances)
325
    end
326

    
327
let print_machine_struct_from_header fmt inode =
328
  if inode.nodei_stateless then
329
    begin
330
    end
331
  else
332
    begin
333
      (* Declare struct *)
334
      fprintf fmt "@[%a;@]@."
335
	pp_machine_memtype_name inode.nodei_id
336
    end
337

    
338
(********************************************************************************************)
339
(*                      Prototype Printing functions                                        *)
340
(********************************************************************************************)
341

    
342
let print_global_init_prototype fmt baseNAME =
343
  fprintf fmt "void %a ()"
344
    pp_global_init_name baseNAME
345

    
346
let print_global_clear_prototype fmt baseNAME =
347
  fprintf fmt "void %a ()"
348
    pp_global_clear_name baseNAME
349

    
350
let print_alloc_prototype fmt (name, static) =
351
  fprintf fmt "%a * %a (%a)"
352
    pp_machine_memtype_name name
353
    pp_machine_alloc_name name
354
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
355

    
356
let print_dealloc_prototype fmt name =
357
  fprintf fmt "void %a (%a * _alloc)"
358
    pp_machine_dealloc_name name
359
    pp_machine_memtype_name name
360
    
361
let print_reset_prototype self fmt (name, static) =
362
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
363
    pp_machine_reset_name name
364
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
365
    (Utils.pp_final_char_if_non_empty ",@," static) 
366
    pp_machine_memtype_name name
367
    self
368

    
369
let print_init_prototype self fmt (name, static) =
370
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
371
    pp_machine_init_name name
372
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
373
    (Utils.pp_final_char_if_non_empty ",@," static) 
374
    pp_machine_memtype_name name
375
    self
376

    
377
let print_clear_prototype self fmt (name, static) =
378
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
379
    pp_machine_clear_name name
380
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
381
    (Utils.pp_final_char_if_non_empty ",@," static) 
382
    pp_machine_memtype_name name
383
    self
384

    
385
let print_stateless_prototype fmt (name, inputs, outputs) =
386
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
387
    pp_machine_step_name name
388
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
389
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
390
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
391

    
392
let print_step_prototype self fmt (name, inputs, outputs) =
393
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
394
    pp_machine_step_name name
395
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
396
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
397
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
398
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
399
    pp_machine_memtype_name name
400
    self
401

    
402
let print_stateless_C_prototype fmt (name, inputs, outputs) =
403
  let output = 
404
    match outputs with
405
    | [hd] -> hd
406
    | _ -> assert false
407
  in
408
  fprintf fmt "%a %s (@[<v>@[%a@]@,@])"
409
    pp_basic_c_type output.var_type
410
    name
411
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
412
    
413
let print_import_init fmt (Dep (local, basename, _, _)) =
414
  if local then
415
    let baseNAME = file_to_module_name basename in
416
    fprintf fmt "%a();" pp_global_init_name baseNAME
417
  else ()
418

    
419
let print_import_clear fmt (Dep (local, basename, _, _)) =
420
  if local then
421
    let baseNAME = file_to_module_name basename in
422
    fprintf fmt "%a();" pp_global_clear_name baseNAME
423
  else ()
424

    
425
let print_import_prototype fmt (Dep (_, s, _, _)) =
426
  fprintf fmt "#include \"%s.h\"@," s
427

    
428
let print_import_alloc_prototype fmt (Dep (_, s, _, stateful)) =
429
  if stateful then
430
    fprintf fmt "#include \"%s_alloc.h\"@," s
431

    
432
let print_extern_alloc_prototypes fmt (Dep (_,_, header,_)) =
433
  List.iter (fun decl -> match decl.top_decl_desc with
434
  | ImportedNode ind when not ind.nodei_stateless ->
435
    let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in
436
    begin
437
      fprintf fmt "extern %a;@.@." print_alloc_prototype (ind.nodei_id, static);
438
      fprintf fmt "extern %a;@.@." print_dealloc_prototype ind.nodei_id;
439
    end
440
  | _                -> ()
441
  ) header
442

    
443

    
444
let pp_c_main_var_input fmt id =  
445
  fprintf fmt "%s" id.var_id
446

    
447
let pp_c_main_var_output fmt id =
448
  if Types.is_address_type id.var_type
449
  then
450
    fprintf fmt "%s" id.var_id
451
  else
452
    fprintf fmt "&%s" id.var_id
453

    
454
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
455
  if fst (get_stateless_status m)
456
  then
457
    fprintf fmt "%a (%a%t%a);"
458
      pp_machine_step_name mname
459
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
460
      (Utils.pp_final_char_if_non_empty ", " inputs) 
461
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
462
  else
463
    fprintf fmt "%a (%a%t%a%t%s);"
464
      pp_machine_step_name mname
465
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
466
      (Utils.pp_final_char_if_non_empty ", " inputs) 
467
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
468
      (Utils.pp_final_char_if_non_empty ", " outputs)
469
      self
470

    
471
let pp_c_var m self pp_var fmt var =
472
  if is_memory m var
473
  then
474
    pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)
475
  else
476
    pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)
477
  
478

    
479
let pp_array_suffix fmt loop_vars =
480
  Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars
481

    
482
(* type directed initialization: useless wrt the lustre compilation model,
483
   except for MPFR injection, where values are dynamically allocated
484
*)
485
let pp_initialize m self pp_var fmt var =
486
  let rec aux indices fmt typ =
487
    if Types.is_array_type typ
488
    then
489
      let dim = Types.array_type_dimension typ in
490
      let idx = mk_loop_var m () in
491
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
492
	idx idx idx pp_c_dimension dim idx
493
	(aux (idx::indices)) (Types.array_element_type typ)
494
    else
495
      let indices = List.rev indices in
496
      let pp_var_suffix fmt var =
497
	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
498
      Mpfr.pp_inject_init pp_var_suffix fmt var
499
  in
500
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
501
  then
502
    begin
503
      reset_loop_counter ();
504
      aux [] fmt var.var_type
505
    end
506

    
507
let pp_const_initialize pp_var fmt const =
508
  let var = mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in
509
  let rec aux indices value fmt typ =
510
    if Types.is_array_type typ
511
    then
512
      let dim = Types.array_type_dimension typ in
513
      let szl = Utils.enumerate (Dimension.size_const_dimension dim) in
514
      let typ' = Types.array_element_type typ in
515
      let value = match value with
516
	| Const_array ca -> List.nth ca
517
	| _                      -> assert false in
518
      fprintf fmt "%a"
519
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> aux (string_of_int i::indices) (value i) fmt typ')) szl
520
    else
521
      let indices = List.rev indices in
522
      let pp_var_suffix fmt var =
523
	fprintf fmt "%a%a" (pp_c_val "" pp_var) var pp_array_suffix indices in
524
      begin
525
	Mpfr.pp_inject_init pp_var_suffix fmt var;
526
	fprintf fmt "@,";
527
	Mpfr.pp_inject_real pp_var_suffix pp_c_const fmt var value
528
      end
529
  in
530
  if !Options.mpfr && Types.is_real_type (Types.array_base_type const.const_type)
531
  then
532
    begin
533
      reset_loop_counter ();
534
      aux [] const.const_value fmt const.const_type
535
    end
536

    
537
(* type directed clear: useless wrt the lustre compilation model,
538
   except for MPFR injection, where values are dynamically allocated
539
*)
540
let pp_clear m self pp_var fmt var =
541
  let rec aux indices fmt typ =
542
    if Types.is_array_type typ
543
    then
544
      let dim = Types.array_type_dimension typ in
545
      let idx = mk_loop_var m () in
546
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
547
	idx idx idx pp_c_dimension dim idx
548
	(aux (idx::indices)) (Types.array_element_type typ)
549
    else
550
      let indices = List.rev indices in
551
      let pp_var_suffix fmt var =
552
	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
553
      Mpfr.pp_inject_clear pp_var_suffix fmt var
554
  in
555
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
556
  then
557
    begin
558
      reset_loop_counter ();
559
      aux [] fmt var.var_type
560
    end
561

    
562
let pp_const_clear pp_var fmt const =
563
  let m = Machine_code.empty_machine in
564
  let var = Corelang.var_decl_of_const const in
565
  let rec aux indices fmt typ =
566
    if Types.is_array_type typ
567
    then
568
      let dim = Types.array_type_dimension typ in
569
      let idx = mk_loop_var m () in
570
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
571
	idx idx idx pp_c_dimension dim idx
572
	(aux (idx::indices)) (Types.array_element_type typ)
573
    else
574
      let indices = List.rev indices in
575
      let pp_var_suffix fmt var =
576
	fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in
577
      Mpfr.pp_inject_clear pp_var_suffix fmt var 
578
  in
579
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
580
  then
581
    begin
582
      reset_loop_counter ();
583
      aux [] fmt var.var_type
584
    end
585

    
586
let pp_call m self pp_read pp_write fmt i (inputs: value_t list) (outputs: var_decl list) =
587
 try (* stateful node instance *)
588
   let (n,_) = List.assoc i m.minstances in
589
   fprintf fmt "%a (%a%t%a%t%s->%s);"
590
     pp_machine_step_name (node_name n)
591
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
592
     (Utils.pp_final_char_if_non_empty ", " inputs) 
593
     (Utils.fprintf_list ~sep:", " pp_write) outputs
594
     (Utils.pp_final_char_if_non_empty ", " outputs)
595
     self
596
     i
597
 with Not_found -> (* stateless node instance *)
598
   let (n,_) = List.assoc i m.mcalls in
599
   fprintf fmt "%a (%a%t%a);"
600
     pp_machine_step_name (node_name n)
601
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
602
     (Utils.pp_final_char_if_non_empty ", " inputs) 
603
     (Utils.fprintf_list ~sep:", " pp_write) outputs 
604

    
605
let pp_basic_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
606
  pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs
607
(*
608
 try (* stateful node instance *)
609
   let (n,_) = List.assoc i m.minstances in
610
   fprintf fmt "%a (%a%t%a%t%s->%s);"
611
     pp_machine_step_name (node_name n)
612
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
613
     (Utils.pp_final_char_if_non_empty ", " inputs) 
614
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
615
     (Utils.pp_final_char_if_non_empty ", " outputs)
616
     self
617
     i
618
 with Not_found -> (* stateless node instance *)
619
   let (n,_) = List.assoc i m.mcalls in
620
   fprintf fmt "%a (%a%t%a);"
621
     pp_machine_step_name (node_name n)
622
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
623
     (Utils.pp_final_char_if_non_empty ", " inputs) 
624
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
625
*)
626

    
627
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
628
  let pp_offset pp_var indices fmt var =
629
    match indices with
630
    | [] -> fprintf fmt "%a" pp_var var
631
    | _  -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in
632
  let rec aux indices fmt typ =
633
    if Types.is_array_type typ
634
    then
635
      let dim = Types.array_type_dimension typ in
636
      let idx = mk_loop_var m () in
637
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
638
	idx idx idx pp_c_dimension dim idx
639
	(aux (idx::indices)) (Types.array_element_type typ)
640
    else
641
      let pp_read  = pp_offset (pp_c_var_read  m) indices in
642
      let pp_write = pp_offset (pp_c_var_write m) indices in
643
      pp_call m self pp_read pp_write fmt i inputs outputs
644
  in
645
  begin
646
    reset_loop_counter ();
647
    aux [] fmt (List.hd inputs).value_type
648
  end
649

    
650
(* Local Variables: *)
651
(* compile-command:"make -C ../../.." *)
652
(* End: *)