Project

General

Profile

Download (24.8 KB) Statistics
| Branch: | Tag: | Revision:
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 protect_filename s =
27
  Str.global_replace (Str.regexp "\\.\\|\\ ") "_" s
28

    
29
let file_to_module_name basename =
30
  let baseNAME = Ocaml_utils.uppercase basename in
31
  let baseNAME = protect_filename baseNAME in
32
  baseNAME
33

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

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

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

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

    
68
(* counter for loop variable creation *)
69
let loop_cpt = ref (-1)
70

    
71
let reset_loop_counter () =
72
 loop_cpt := -1
73

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

    
84
let reset_addr_counter () =
85
 addr_cpt := -1
86

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

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

    
126
let is_basic_c_type t =
127
  match (Types.repr t).Types.tdesc with
128
  | Types.Tbool | Types.Treal | Types.Tint  -> true
129
  | _                                       -> false
130

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

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

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

    
172

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

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

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

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

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

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

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

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

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

    
288
let pp_c_decl_instance_var fmt (name, (node, static)) = 
289
  fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
290

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

    
302
(********************************************************************************************)
303
(*                       Struct Printing functions                                          *)
304
(********************************************************************************************)
305

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

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

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

    
341
(********************************************************************************************)
342
(*                      Prototype Printing functions                                        *)
343
(********************************************************************************************)
344

    
345
let print_global_init_prototype fmt baseNAME =
346
  fprintf fmt "void %a ()"
347
    pp_global_init_name baseNAME
348

    
349
let print_global_clear_prototype fmt baseNAME =
350
  fprintf fmt "void %a ()"
351
    pp_global_clear_name baseNAME
352

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

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

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

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

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

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

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

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

    
428
let print_import_prototype fmt (Dep (_, s, _, _)) =
429
  fprintf fmt "#include \"%s.h\"@," s
430

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

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

    
446

    
447
let pp_c_main_var_input fmt id =  
448
  fprintf fmt "%s" id.var_id
449

    
450
let pp_c_main_var_output fmt id =
451
  if Types.is_address_type id.var_type
452
  then
453
    fprintf fmt "%s" id.var_id
454
  else
455
    fprintf fmt "&%s" id.var_id
456

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

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

    
482
let pp_array_suffix fmt loop_vars =
483
  Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars
484

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

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

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

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

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

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

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

    
653

    
654
(*** Common functions for main ***)
655

    
656
let print_put_var fmt file_suffix name var_type var_id =
657
  match (Types.unclock_type var_type).Types.tdesc with
658
  | Types.Tint -> fprintf fmt "_put_int(f_out%s, \"%s\", %s)" file_suffix name var_id
659
  | Types.Tbool -> fprintf fmt "_put_bool(f_out%s, \"%s\", %s)" file_suffix name var_id
660
  | Types.Treal when !Options.mpfr -> fprintf fmt "_put_double(f_out%s, \"%s\", mpfr_get_d(%s, %s), %i)" file_suffix name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double
661
  | Types.Treal -> fprintf fmt "_put_double(f_out%s, \"%s\", %s, %i)" file_suffix name var_id !Options.print_prec_double
662
  | _ -> Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty var_type; assert false
663

    
664
(* Local Variables: *)
665
(* compile-command:"make -C ../../.." *)
666
(* End: *)
(3-3/10)