Project

General

Profile

Revision 70e1006b

View differences:

src/automata.ml
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 LustreSpec
13
open Corelang
14

  
15
let mkbool loc b =
16
 mkexpr loc (Expr_const (const_of_bool b))
17

  
18
let mkident loc id =
19
 mkexpr loc (Expr_ident id)
20

  
21
let init (loc, restart, st) =
22
 mkexpr loc (Expr_tuple [mkbool loc restart; mkident loc st])
23

  
24
let add_branch expr (loc, restart, st) cont =
25
 mkexpr loc (Expr_ite (expr, init (loc, restart, st), cont))
26

  
27
let mkhandler loc st unless until locals eqs =
28
 {hand_state = st;
29
  hand_unless = unless;
30
  hand_until = until;
31
  hand_locals = locals;
32
  hand_eqs = eqs;
33
  hand_loc = loc}
34

  
35
let mkautomata loc id handlers =
36
  {aut_id = id;
37
   aut_handlers = handlers;
38
   aut_loc = loc}
39

  
40
let pp_restart fmt restart =
41
  Format.fprintf fmt "%s" (if restart then "restart" else "resume")
42

  
43
let pp_unless fmt (expr, restart, st) =
44
  Format.fprintf fmt "unless %a %a %s"
45
    Printers.pp_expr expr
46
    pp_restart restart
47
    st
48

  
49
let pp_until fmt (expr, restart, st) =
50
  Format.fprintf fmt "until %a %a %s"
51
    Printers.pp_expr expr
52
    pp_restart restart
53
    st
54

  
55
let pp_handler fmt handler =
56
  Format.fprintf fmt "state %s -> %a %a let %a tel %a"
57
    handler.hand_state
58
    (Utils.fprintf_list ~sep:"@ " pp_unless) handler.hand_unless
59
    (fun fmt locals ->
60
      match locals with [] -> () | _ ->
61
	Format.fprintf fmt "@[<v 4>var %a@]@ " 
62
	  (Utils.fprintf_list ~sep:"@ " 
63
	     (fun fmt v -> Format.fprintf fmt "%a;" Printers.pp_node_var v))
64
	  locals)
65
    handler.hand_locals
66
    Printers.pp_node_eqs handler.hand_eqs
67
    (Utils.fprintf_list ~sep:"@ " pp_until) handler.hand_until
68

  
69
let pp_automata fmt aut =
70
  Format.fprintf fmt "automaton %s %a"
71
    aut.aut_id
72
    (Utils.fprintf_list ~sep:"@ " pp_handler) aut.aut_handlers
73

  
74
(*
75
let rec extract_node expr top_decls =
76
  match expr.expr_desc with
77
  | Expr_const _
78
  | Expr_ident _
79
  | Expr_tuple _
80
  | Expr_ite   of expr * expr * expr
81
  | Expr_arrow of expr * expr
82
  | Expr_fby of expr * expr
83
  | Expr_array of expr list
84
  | Expr_access of expr * Dimension.dim_expr
85
  | Expr_power of expr * Dimension.dim_expr
86
  | Expr_pre of expr
87
  | Expr_when of expr * ident * label
88
  | Expr_merge of ident * (label * expr) list
89
  | Expr_appl
90
*)
91

  
92
(* Local Variables: *)
93
(* compile-command:"make -C .." *)
94
(* End: *)
src/backends/C/c_backend.ml
13 13
(********************************************************************************************)
14 14
(*                         Translation function                                             *)
15 15
(********************************************************************************************)
16

  
16
(* USELESS
17 17
let makefile_opt print basename dependencies makefile_fmt machines =
18 18
  (* If a main node is identified, generate a main target for it *)
19 19
  match !Options.main_node with
......
23 23
    | None -> Format.eprintf "Unable to find a main node named %s@.@?" main_node; ()
24 24
    | Some _ -> print basename !Options.main_node dependencies makefile_fmt
25 25
  )
26

  
26
*)
27 27

  
28 28
let gen_files funs basename prog machines dependencies header_file source_lib_file source_main_file makefile_file machines =
29 29
  let header_out = open_out header_file in
......
33 33
  
34 34
  let print_header, print_lib_c, print_main_c, print_makefile = funs in
35 35
  (* Generating H file *)
36
  print_header header_fmt basename prog machines;
36
  print_header header_fmt basename prog machines dependencies;
37 37
  
38 38
  (* Generating Lib C file *)
39 39
  print_lib_c source_lib_fmt basename prog machines dependencies;
40 40

  
41
  close_out header_out;
42
  close_out source_lib_out;
43

  
41 44
  match !Options.main_node with
42 45
  | "" ->  () (* No main node: we do not genenrate main nor makefile *)
43 46
  | main_node -> (
......
53 56
      print_main_c source_main_fmt m basename prog machines dependencies;
54 57
      
55 58
      (* Generating Makefile *)
56
     print_makefile basename main_node dependencies makefile_fmt
59
     print_makefile basename main_node dependencies makefile_fmt;
60

  
61
     close_out source_main_out;
62
     close_out makefile_out
63

  
57 64
    end
58 65
  )
59
    
60

  
61 66

  
62 67
let translate_to_c header source_lib source_main makefile basename prog machines dependencies =
63 68

  
......
73 78
    let module SourceMain = C_backend_main.Main (SourceMainMod) in
74 79
    let module Makefile = C_backend_makefile.Main (MakefileMod) in
75 80
        
76
    let funs = Header.print_header, Source.print_lib_c, SourceMain.print_main_c, Makefile.print_makefile in
81
    let funs = Header.print_alloc_header, Source.print_lib_c, SourceMain.print_main_c, Makefile.print_makefile in
77 82
    gen_files funs basename prog machines dependencies header source_lib source_main makefile machines
78 83

  
79 84
  end
......
89 94
    let module SourceMain = C_backend_main.Main (SourceMainMod) in
90 95
    let module Makefile = C_backend_makefile.Main (MakefileMod) in
91 96
        
92
    let funs = Header.print_header, Source.print_lib_c, SourceMain.print_main_c, Makefile.print_makefile in
97
    let funs = Header.print_alloc_header, Source.print_lib_c, SourceMain.print_main_c, Makefile.print_makefile in
93 98
    gen_files funs basename prog machines dependencies header source_lib source_main makefile machines
94 99

  
95 100
  end
src/backends/C/c_backend_common.ml
21 21
    (Filename.basename Sys.executable_name) 
22 22
    Version.number 
23 23
    (if !Options.ansi then "ANSI C90" else "C99")
24

  
25

  
24
 
26 25
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
27 26
let mk_self m =
28 27
  mk_new_name (m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory) "self"
......
235 234
    fmt 
236 235
    m.mstep.step_checks
237 236

  
237
(********************************************************************************************)
238
(*                       Struct Printing functions                                          *)
239
(********************************************************************************************)
240

  
241
let pp_registers_struct fmt m =
242
  if m.mmemory <> []
243
  then
244
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
245
      pp_machine_regtype_name m.mname.node_id
246
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
247
  else
248
    ()
249

  
250
let print_machine_struct fmt m =
251
  if fst (get_stateless_status m) then
252
    begin
253
    end
254
  else
255
    begin
256
      (* Define struct *)
257
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
258
	pp_machine_memtype_name m.mname.node_id
259
	pp_registers_struct m
260
	(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
261
	(Utils.pp_final_char_if_non_empty "; " m.minstances)
262
    end
263

  
264
let print_machine_struct_from_header fmt inode =
265
  if inode.nodei_stateless then
266
    begin
267
    end
268
  else
269
    begin
270
      (* Declare struct *)
271
      fprintf fmt "@[%a;@]@."
272
	pp_machine_memtype_name inode.nodei_id
273
    end
238 274

  
239 275
(********************************************************************************************)
240 276
(*                      Prototype Printing functions                                        *)
......
271 307
    pp_machine_memtype_name name
272 308
    self
273 309

  
274
let print_import_prototype fmt (s, _, _) =
310
let print_import_prototype fmt (_, s, _) =
275 311
  fprintf fmt "#include \"%s.h\"@," s
276 312

  
313
let print_import_alloc_prototype fmt (_, s, _) =
314
  fprintf fmt "#include \"%s_alloc.h\"@," s
315

  
316
let print_extern_alloc_prototypes fmt (_,_, header) =
317
  List.iter (fun decl -> match decl.top_decl_desc with
318
  | ImportedNode ind when not ind.nodei_stateless ->
319
    let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs
320
    in fprintf fmt "extern %a;@." print_alloc_prototype (ind.nodei_id, static)
321
  | _                -> ()
322
  ) header
323

  
277 324
(* Local Variables: *)
278 325
(* compile-command:"make -C ../../.." *)
279 326
(* End: *)
src/backends/C/c_backend_header.ml
36 36
let print_import_standard fmt =
37 37
  fprintf fmt "#include \"%s/include/lustrec/arrow.h\"@.@." Version.prefix
38 38

  
39
    
40
let pp_registers_struct fmt m =
41
  if m.mmemory <> []
42
  then
43
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
44
      pp_machine_regtype_name m.mname.node_id
45
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
46
  else
47
    ()
48

  
49
let print_machine_struct fmt m =
50
  if fst (get_stateless_status m) then
51
    begin
52
    end
53
  else
54
    begin
55
      (* Define struct *)
56
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
57
	pp_machine_memtype_name m.mname.node_id
58
	pp_registers_struct m
59
	(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
60
	(Utils.pp_final_char_if_non_empty "; " m.minstances)
61
    end
62

  
63 39
let print_static_declare_instance attr fmt (i, (m, static)) =
64 40
  fprintf fmt "%a(%s, %a%t%s)"
65 41
    pp_machine_static_declare_name (node_name m)
......
161 137
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
162 138
    end
163 139

  
140
let print_machine_alloc_decl fmt m =
141
  Mod.print_machine_decl_prefix fmt m;
142
  if fst (get_stateless_status m) then
143
    begin
144
    end
145
  else
146
    begin
147
      if !Options.static_mem
148
      then
149
	begin
150
	  (* Static allocation *)
151
	  fprintf fmt "%a@.%a@.%a@."
152
		  print_static_declare_macro m
153
		  print_static_link_macro m
154
		  print_static_alloc_macro m
155
	end
156
      else
157
	begin 
158
          (* Dynamic allocation *)
159
	  fprintf fmt "extern %a;@."
160
		  print_alloc_prototype (m.mname.node_id, m.mstatic)
161
	end
162
    end
163

  
164
let print_machine_decl_from_header fmt inode =
165
  (*Mod.print_machine_decl_prefix fmt m;*)
166
  if inode.nodei_stateless then
167
    begin
168
      fprintf fmt "extern %a;@.@."
169
	print_stateless_prototype
170
	(inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs)
171
    end
172
  else
173
    begin
174
      let static_inputs = List.filter (fun v -> v.var_dec_const) inode.nodei_inputs in
175
      let self = mk_new_name (inode.nodei_inputs@inode.nodei_outputs) "self" in
176
      fprintf fmt "extern %a;@.@."
177
	(print_reset_prototype self) (inode.nodei_id, static_inputs);
178

  
179
      fprintf fmt "extern %a;@.@."
180
	(print_step_prototype self)
181
	(inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs)
182
    end
183

  
164 184
let print_const_decl fmt cdecl =
165 185
  fprintf fmt "extern %a;@." 
166 186
    (pp_c_type cdecl.const_id) cdecl.const_type
167 187

  
168
(********************************************************************************************)
169
(*                      Struct/TypeDef Printing functions                                   *)
170
(********************************************************************************************)
171

  
172

  
173 188
let rec pp_c_struct_type_field filename cpt fmt (label, tdesc) =
174 189
  fprintf fmt "%a;" (pp_c_type_decl filename cpt label) tdesc
175 190
and pp_c_type_decl filename cpt var fmt tdecl =
......
195 210

  
196 211
let print_type_definitions fmt filename =
197 212
  let cpt_type = ref 0 in
198
  Hashtbl.iter (fun typ def ->
199
    match typ with
200
    | Tydec_const var ->
201
      fprintf fmt "typedef %a;@.@."
202
	(pp_c_type_decl filename cpt_type var) def
203
    | _        -> ()) type_table
213
  Hashtbl.iter (fun typ decl ->
214
		match typ with
215
		| Tydec_const var ->
216
		   (match decl.top_decl_desc with
217
		    | TypeDef tdef ->
218
		       fprintf fmt "typedef %a;@.@."
219
			       (pp_c_type_decl filename cpt_type var) tdef.tydef_desc
220
		    | _ -> assert false)
221
		| _        -> ()) type_table
222

  
223
let reset_type_definitions, print_type_definition_from_header =
224
  let cpt_type =ref 0 in
225
  ((fun () -> cpt_type := 0),
226
   (fun fmt typ filename ->
227
    fprintf fmt "typedef %a;@.@."
228
	(pp_c_type_decl filename cpt_type typ.tydef_id) typ.tydef_desc))
204 229

  
205 230
(********************************************************************************************)
206 231
(*                         MAIN Header Printing functions                                   *)
207 232
(********************************************************************************************)
208
let print_header header_fmt basename prog machines =
233
let print_header header_fmt basename prog machines dependencies =
209 234
  (* Include once: start *)
210 235
  let baseNAME = String.uppercase basename in
211 236
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
212
  (* Print the svn version number and the supported C standard (C90 or C99) *)
213
  print_version header_fmt;
214
  fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
215
  pp_print_newline header_fmt ();
216
  fprintf header_fmt "/* Imports standard library */@.";
217
  (* imports standard library definitions (arrow) *)
218
  print_import_standard header_fmt;
219
  pp_print_newline header_fmt ();
220
  fprintf header_fmt "/* Types definitions */@.";
221
  (* Print the type definitions from the type table *)
222
  print_type_definitions header_fmt basename;
223
  pp_print_newline header_fmt ();
224
  (* Print the global constant declarations. *)
225
  fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
226
  List.iter (fun c -> print_const_decl header_fmt c) (get_consts prog);
227
  pp_print_newline header_fmt ();
228
  (* Print the struct declarations of all machines. *)
229
  fprintf header_fmt "/* Struct declarations */@.";
230
  List.iter (print_machine_struct header_fmt) machines;
231
  pp_print_newline header_fmt ();
232
  (* Print the prototypes of all machines *)
233
  fprintf header_fmt "/* Nodes declarations */@.";
234
  List.iter (print_machine_decl header_fmt) machines;
235
  pp_print_newline header_fmt ();
236
  (* Include once: end *)
237
  fprintf header_fmt "#endif@.";
238
  pp_print_newline header_fmt ()
239
end
237
  begin
238
    (* Print the svn version number and the supported C standard (C90 or C99) *)
239
    print_version header_fmt;
240
    fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
241
    pp_print_newline header_fmt ();
242
    fprintf header_fmt "/* Imports standard library */@.";
243
    (* imports standard library definitions (arrow) *)
244
    print_import_standard header_fmt;
245
    pp_print_newline header_fmt ();
246
    (* imports dependencies *)
247
    fprintf header_fmt "/* Import Dependencies */@.";
248
    fprintf header_fmt "@[<v>";
249
    List.iter (print_import_prototype header_fmt) dependencies;
250
    fprintf header_fmt "@]@.";
251
    fprintf header_fmt "/* Types definitions */@.";
252
    (* Print the type definitions from the type table *)
253
    print_type_definitions header_fmt basename;
254
    pp_print_newline header_fmt ();
255
    (* Print the global constant declarations. *)
256
    fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
257
    List.iter (fun c -> print_const_decl header_fmt (const_of_top c)) (get_consts prog);
258
    pp_print_newline header_fmt ();
259
    (* Print the struct declarations of all machines. *)
260
    fprintf header_fmt "/* Struct declarations */@.";
261
    List.iter (print_machine_struct header_fmt) machines;
262
    pp_print_newline header_fmt ();
263
    (* Print the prototypes of all machines *)
264
    fprintf header_fmt "/* Nodes declarations */@.";
265
    List.iter (print_machine_decl header_fmt) machines;
266
    pp_print_newline header_fmt ();
267
    (* Include once: end *)
268
    fprintf header_fmt "#endif@.";
269
    pp_print_newline header_fmt ()
270
  end
271

  
272
let print_alloc_header header_fmt basename prog machines dependencies =
273
  (* Include once: start *)
274
  let baseNAME = String.uppercase basename in
275
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
276
  begin
277
    (* Print the svn version number and the supported C standard (C90 or C99) *)
278
    print_version header_fmt;
279
    fprintf header_fmt "#ifndef _%s_alloc@.#define _%s_alloc@." baseNAME baseNAME;
280
    pp_print_newline header_fmt ();
281
    (* Import the header *)
282
    fprintf header_fmt "/* Import header from %s */@." basename;
283
    fprintf header_fmt "@[<v>";
284
    print_import_prototype header_fmt (true, basename, []);
285
    fprintf header_fmt "@]@.";
286
    fprintf header_fmt "/* Import dependencies */@.";
287
    fprintf header_fmt "@[<v>";
288
    List.iter (print_import_alloc_prototype header_fmt) dependencies;
289
    fprintf header_fmt "@]@.";
290
    (* Print the struct definitions of all machines. *)
291
    fprintf header_fmt "/* Struct definitions */@.";
292
    List.iter (print_machine_struct header_fmt) machines;
293
    pp_print_newline header_fmt ();
294
    (* Print the prototypes of all machines *)
295
    fprintf header_fmt "/* Node allocation function/macro prototypes */@.";
296
    List.iter (print_machine_alloc_decl header_fmt) machines;
297
    pp_print_newline header_fmt ();
298
    (* Include once: end *)
299
    fprintf header_fmt "#endif@.";
300
    pp_print_newline header_fmt ()
301
  end
240 302

  
303
let print_header_from_header header_fmt basename header =
304
  (* Include once: start *)
305
  let baseNAME = String.uppercase basename in
306
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
307
  let types = get_typedefs header in
308
  let consts = get_consts header in
309
  let nodes = get_imported_nodes header in
310
  let dependencies = get_dependencies header in
311
  begin
312
    (* Print the svn version number and the supported C standard (C90 or C99) *)
313
    print_version header_fmt;
314
    fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
315
    pp_print_newline header_fmt ();
316
    fprintf header_fmt "/* Imports standard library */@.";
317
    (* imports standard library definitions (arrow) *)
318
    print_import_standard header_fmt;
319
    pp_print_newline header_fmt ();
320
    (* imports dependencies *)
321
    fprintf header_fmt "/* Import dependencies */@.";
322
    fprintf header_fmt "@[<v>";
323
    List.iter
324
      (fun dep -> let (local, s) = dependency_of_top dep in print_import_prototype header_fmt (local, s, []))
325
      dependencies;
326
    fprintf header_fmt "@]@.";
327
    fprintf header_fmt "/* Types definitions */@.";
328
    (* Print the type definitions from the type table *)
329
    reset_type_definitions ();
330
    List.iter (fun typ -> print_type_definition_from_header header_fmt (typedef_of_top typ) basename) types;
331
    pp_print_newline header_fmt ();
332
    (* Print the global constant declarations. *)
333
    fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
334
    List.iter (fun c -> print_const_decl header_fmt (const_of_top c)) consts;
335
    pp_print_newline header_fmt ();
336
    (* Print the struct declarations of all machines. *)
337
    fprintf header_fmt "/* Struct declarations */@.";
338
    List.iter (fun node -> print_machine_struct_from_header header_fmt (imported_node_of_top node)) nodes;
339
    pp_print_newline header_fmt ();
340
    (* Print the prototypes of all machines *)
341
    fprintf header_fmt "/* Nodes declarations */@.";
342
    List.iter (fun node -> print_machine_decl_from_header header_fmt (imported_node_of_top node)) nodes;
343
    pp_print_newline header_fmt ();
344
    (* Include once: end *)
345
    fprintf header_fmt "#endif@.";
346
    pp_print_newline header_fmt ()
347
  end
348

  
349
end
241 350
(* Local Variables: *)
242 351
(* compile-command:"make -C ../../.." *)
243 352
(* End: *)
src/backends/C/c_backend_main.ml
112 112

  
113 113
let print_main_c main_fmt main_machine basename prog machines dependencies =
114 114
  print_main_header main_fmt;
115
  fprintf main_fmt "#include <stdlib.h>@.#include <assert.h>@.#include \"%s\"@.@." (basename^".h");
115
  fprintf main_fmt "#include <stdlib.h>@.#include <assert.h>@.";
116
  print_import_alloc_prototype main_fmt (true, basename, []);
117
  pp_print_newline main_fmt ();
118

  
116 119
  (* Print the svn version number and the supported C standard (C90 or C99) *)
117 120
  print_version main_fmt;
118 121
  print_main_fun machines main_machine main_fmt
src/backends/C/c_backend_makefile.ml
17 17
  List.exists 
18 18
    (fun top -> 
19 19
      match top.top_decl_desc with
20
      | Consts _ -> true 
20
      | Const _ -> true 
21 21
      | ImportedNode nd -> nd.nodei_in_lib = None
22 22
      | _ -> false
23 23
    )
......
46 46
    fprintf fmt "\t${GCC} -I${INC} -c %s@." s)
47 47
    (("${INC}/io_frontend.c"):: (* IO functions when a main function is computed *)
48 48
	(List.map 
49
	   (fun (s, local, _) -> 
49
	   (fun (local, s, _) -> 
50 50
	     (if local then s else Version.prefix ^ "/include/lustrec/" ^ s) ^ ".c")
51 51
	   compiled_dep))
52 52

  
53 53
module type MODIFIERS_MKF =
54 54
sig
55
  val other_targets: Format.formatter -> string -> string -> (string * bool * top_decl list) list -> unit
55
  val other_targets: Format.formatter -> string -> string -> (bool * string * top_decl list) list -> unit
56 56
end
57 57

  
58 58
module EmptyMod =
......
77 77
  fprintf fmt "\t${GCC} -I${INC} -I. -c %s_main.c@." basename;   
78 78
  fprintf_dependencies fmt dependencies;    
79 79
  fprintf fmt "\t${GCC} -o %s_%s io_frontend.o %a %s.o %s_main.o %a@." basename nodename 
80
    (Utils.fprintf_list ~sep:" " (fun fmt (s, _, _) -> Format.fprintf fmt "%s.o" s)) (compiled_dependencies dependencies)
80
    (Utils.fprintf_list ~sep:" " (fun fmt (_, s, _) -> Format.fprintf fmt "%s.o" s)) (compiled_dependencies dependencies)
81 81
    basename (* library .o *)
82 82
    basename (* main function . o *) 
83 83
    (Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib)) (lib_dependencies dependencies)
src/backends/C/c_backend_spec.ml
158 158
  C_backend_makefile.fprintf_dependencies fmt dependencies; 
159 159
  fprintf fmt "\t${GCC} -Wno-attributes -o %s_main_eacsl io_frontend.o %a %s %s_main_eacsl.o %a@." 
160 160
    basename 
161
    (Utils.fprintf_list ~sep:" " (fun fmt (s, _, _) -> Format.fprintf fmt "%s.o" s)) 
161
    (Utils.fprintf_list ~sep:" " (fun fmt (_, s, _) -> Format.fprintf fmt "%s.o" s)) 
162 162
    (C_backend_makefile.compiled_dependencies dependencies)
163 163
    ("${FRAMACEACSL}/e_acsl.c " 
164 164
     ^ "${FRAMACEACSL}/memory_model/e_acsl_bittree.c " 
src/backends/C/c_backend_src.ml
259 259

  
260 260
let print_stateless_code dependencies fmt m =
261 261
  let self = "__ERROR__" in
262
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
262
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false })
263 263
  then
264 264
    (* C99 code *)
265 265
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
......
296 296
    (Utils.pp_newline_if_non_empty m.minit)
297 297

  
298 298
let print_step_code dependencies fmt m self =
299
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
299
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false })
300 300
  then
301 301
    (* C99 code *)
302 302
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
......
345 345
    begin
346 346
      (* Alloc function, only if non static mode *)
347 347
      if (not !Options.static_mem) then  
348
	(
348
	begin
349 349
	  fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@."
350 350
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
351 351
	    print_alloc_code m;
352
	);
352
	end;
353 353
      let self = mk_self m in
354 354
      (* Reset function *)
355 355
      print_reset_code dependencies fmt m self;
......
360 360

  
361 361
let print_lib_c source_fmt basename prog machines dependencies =
362 362

  
363
  fprintf source_fmt "#include <stdlib.h>@.#include <assert.h>@.#include \"%s\"@.@." (basename^".h");
363
  fprintf source_fmt "#include <assert.h>@.";
364
  if not !Options.static_mem then
365
    begin
366
      fprintf source_fmt "#include <stdlib.h>@.";
367
    end;
368
  print_import_prototype source_fmt (true, basename, []);
369
  pp_print_newline source_fmt ();
364 370
  (* Print the svn version number and the supported C standard (C90 or C99) *)
365 371
  print_version source_fmt;
366 372
  (* Print the prototype of imported nodes *)
367
  fprintf source_fmt "/* Imported nodes declarations */@.";
373
  fprintf source_fmt "/* Import dependencies */@.";
368 374
  fprintf source_fmt "@[<v>";
369 375
  List.iter (print_import_prototype source_fmt) dependencies;
370 376
  fprintf source_fmt "@]@.";
371 377
  (* Print consts *)
372 378
  fprintf source_fmt "/* Global constants (definitions) */@.";
373
  List.iter (fun c -> print_const_def source_fmt c) (get_consts prog);
379
  fprintf source_fmt "@[<v>";
380
  List.iter (fun c -> print_const_def source_fmt (const_of_top c)) (get_consts prog);
381
  fprintf source_fmt "@]@.";
382
  if not !Options.static_mem then
383
    begin
384
      fprintf source_fmt "/* External allocation function prototypes */@.";
385
      fprintf source_fmt "@[<v>";
386
      List.iter (print_extern_alloc_prototypes source_fmt) dependencies;
387
      fprintf source_fmt "@]@.";
388
      fprintf source_fmt "/* Node allocation function prototypes */@.";
389
      fprintf source_fmt "@[<v>";
390
      List.iter (fun m -> fprintf source_fmt "%a;@." print_alloc_prototype (m.mname.node_id, m.mstatic)) machines;
391
      fprintf source_fmt "@]@.";
392
    end;
393
  (* Print the struct definitions of all machines. *)
394
  fprintf source_fmt "/* Struct definitions */@.";
395
  fprintf source_fmt "@[<v>";
396
  List.iter (print_machine_struct source_fmt) machines;
397
  fprintf source_fmt "@]@.";
374 398
  pp_print_newline source_fmt ();
375 399
  (* Print nodes one by one (in the previous order) *)
376 400
  List.iter (print_machine dependencies source_fmt) machines;
src/basic_library.ml
27 27
    (fun env (op, op_type) -> TE.add_value env op op_type)
28 28
    TE.initial
29 29
    [
30
       "+", (static_op type_bin_poly_op);
30
      "true", (static_op type_bool);
31
      "false", (static_op type_bool);
32
      "+", (static_op type_bin_poly_op);
31 33
      "uminus", (static_op type_unary_poly_op); 
32 34
      "-", (static_op type_bin_poly_op); 
33 35
      "*", (static_op type_bin_poly_op);
......
51 53

  
52 54
let clock_env =
53 55
  let init_env = CE.initial in
56
  let env' =
57
    List.fold_right (fun op env -> CE.add_value env op ck_nullary_univ)
58
      ["true"; "false"] init_env in
54 59
  let env' = 
55 60
    List.fold_right (fun op env -> CE.add_value env op ck_unary_univ)
56
      ["uminus"; "not"] init_env in
61
      ["uminus"; "not"] env' in
57 62
  let env' = 
58 63
    List.fold_right (fun op env -> CE.add_value env op ck_bin_univ)
59 64
      ["+"; "-"; "*"; "/"; "mod"; "&&"; "||"; "xor"; "equi"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in
......
63 68

  
64 69
let delay_env =
65 70
  let init_env = DE.initial in
66
  let env' = 
71
  let env' =
72
    List.fold_right (fun op env -> DE.add_value env op delay_nullary_poly_op)
73
      ["true"; "false"] init_env in
74
  let env' =
67 75
    List.fold_right (fun op env -> DE.add_value env op delay_unary_poly_op)
68
      ["uminus"; "not"] init_env in
76
      ["uminus"; "not"] env' in
69 77
  let env' = 
70 78
    List.fold_right (fun op env -> DE.add_value env op delay_binary_poly_op)
71 79
      ["+"; "-"; "*"; "/"; "mod"; "&&"; "||"; "xor"; "equi"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in
src/clock_calculus.ml
832 832
  nd.nodei_clock <- ck_node;
833 833
  Env.add_value env nd.nodei_id ck_node
834 834

  
835
let clock_top_consts env clist =
836
  List.fold_left (fun env cdecl ->
837
    let ck = new_var false in
838
    try_generalize ck cdecl.const_loc;
839
    Env.add_value env cdecl.const_id ck) env clist
835
let clock_top_const env cdecl=
836
  let ck = new_var false in
837
  try_generalize ck cdecl.const_loc;
838
  Env.add_value env cdecl.const_id ck
840 839

  
841
let clock_top_decl env decl =
840
let clock_top_consts env clist =
841
  List.fold_left clock_top_const env clist
842
 
843
let rec clock_top_decl env decl =
842 844
  match decl.top_decl_desc with
843 845
  | Node nd ->
844 846
    clock_node env decl.top_decl_loc nd
845 847
  | ImportedNode nd ->
846 848
    clock_imported_node env decl.top_decl_loc nd
847
  | Consts clist ->
848
    clock_top_consts env clist
849
  | Open _
850
  | Type _ -> env
849
  | Const c ->
850
    clock_top_const env c
851
  | TypeDef _ -> List.fold_left clock_top_decl env (consts_of_enum_type decl)
852
  | Open _    -> env
851 853

  
852 854
let clock_prog env decls =
853
  List.fold_left (fun e decl -> clock_top_decl e decl) env decls
855
  List.fold_left clock_top_decl env decls
854 856

  
855 857
(* Once the Lustre program is fully clocked,
856 858
   we must get back to the original description of clocks,
......
878 880
      uneval_node_generics (nd.node_inputs @ nd.node_locals @ nd.node_outputs)
879 881
  | ImportedNode nd ->
880 882
      uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
881
  | Consts _
883
  | Const _
882 884
  | Open _
883
  | Type _   -> ()
885
  | TypeDef _ -> ()
884 886

  
885 887
let uneval_prog_generics prog =
886 888
 List.iter uneval_top_generics prog
src/clock_predef.ml
22 22
  let univ = new_univar () in
23 23
  new_ck (Carrow (new_ck (Ctuple [univ;univ;univ]) true, univ)) true
24 24

  
25
let ck_nullary_univ =
26
  let univ = new_univar () in
27
  univ
28

  
25 29
let ck_unary_univ =
26 30
  let univ = new_univar () in
27 31
  new_ck (Carrow (univ, univ)) true
src/compiler_common.ml
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 Utils
13
open Format 
14
open LustreSpec
15
open Corelang
16

  
17
let create_dest_dir () =
18
  begin
19
    if not (Sys.file_exists !Options.dest_dir) then
20
      begin
21
	Log.report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@,");
22
	Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm
23
      end;
24
    if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then
25
      begin
26
	eprintf "Failure: destination %s is not a directory.@.@." !Options.dest_dir;
27
	exit 1
28
      end
29
  end
30

  
31
(* Loading Lusi file and filling type tables with parsed
32
   functions/nodes *)
33
let parse_header own filename =
34
  Location.set_input filename;
35
  let h_in = open_in filename in
36
  let lexbuf = Lexing.from_channel h_in in
37
  Location.init lexbuf filename;
38
  (* Parsing *)
39
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. parsing header file %s@ " filename);
40
    try
41
      let header = Parse.header Parser_lustre.header Lexer_lustre.token lexbuf in
42
      ignore (Modules.load_header ISet.empty header);
43
      close_in h_in;
44
      header
45
    with
46
    | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
47
      Parse.report_error err;
48
      raise exc
49
    | Corelang.Error (loc, err) as exc -> (
50
      eprintf "Parsing error: %a%a@."
51
	Corelang.pp_error err
52
	Location.pp_loc loc;
53
      raise exc
54
    )
55

  
56
let parse_source source_name =
57
  (* Loading the input file *)
58
  Location.set_input source_name;
59
  let s_in = open_in source_name in
60
  let lexbuf = Lexing.from_channel s_in in
61
  Location.init lexbuf source_name;
62

  
63
  (* Parsing *)
64
  Log.report ~level:1 
65
    (fun fmt -> fprintf fmt ".. parsing source file %s@," source_name);
66
  try
67
    let prog = Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf in
68
    ignore (Modules.load_program ISet.empty prog);
69
    close_in s_in;
70
    prog
71
  with
72
  | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
73
    Parse.report_error err;
74
    raise exc
75
  | Corelang.Error (loc, err) as exc ->
76
    eprintf "Parsing error %a%a@."
77
      Corelang.pp_error err
78
      Location.pp_loc loc;
79
    raise exc
80

  
81
let check_stateless_decls decls =
82
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. checking stateless/stateful status@ ");
83
  try
84
    Stateless.check_prog decls
85
  with (Stateless.Error (loc, err)) as exc ->
86
    eprintf "Stateless status error %a%a@."
87
      Stateless.pp_error err
88
      Location.pp_loc loc;
89
    raise exc
90

  
91
let type_decls env decls =  
92
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. typing@ ");
93
  let new_env = 
94
    begin
95
      try
96
	Typing.type_prog env decls
97
      with (Types.Error (loc,err)) as exc ->
98
	eprintf "Typing error %a%a@."
99
	  Types.pp_error err
100
	  Location.pp_loc loc;
101
	raise exc
102
    end 
103
  in
104
  if !Options.print_types then
105
    Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_type decls);
106
  new_env
107
      
108
let clock_decls env decls = 
109
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@ ");
110
  let new_env =
111
    begin
112
      try
113
	Clock_calculus.clock_prog env decls
114
      with (Clocks.Error (loc,err)) as exc ->
115
	eprintf "Clock calculus error %a%a@." Clocks.pp_error err Location.pp_loc loc;
116
	raise exc
117
    end
118
  in
119
  if !Options.print_clocks then
120
    Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_clock decls);
121
  new_env
122

  
123
let check_top_decls header =
124
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
125
  let new_cenv = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
126
  header, new_tenv, new_cenv
127

  
128
let get_envs_from_const const_decl (ty_env, ck_env) =
129
  (Env.add_value ty_env const_decl.const_id const_decl.const_type,
130
   Env.add_value ck_env const_decl.const_id (Clocks.new_var true))
131

  
132
let get_envs_from_consts const_decls (ty_env, ck_env) =
133
  List.fold_right get_envs_from_const const_decls (ty_env, ck_env)
134

  
135
let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =
136
 match top_decl.top_decl_desc with
137
 | Node nd          -> (Env.add_value ty_env nd.node_id nd.node_type,
138
			Env.add_value ck_env nd.node_id nd.node_clock)
139
 | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
140
			Env.add_value ck_env ind.nodei_id ind.nodei_clock)
141
 | Const c          -> get_envs_from_const c (ty_env, ck_env)
142
 | TypeDef _        -> List.fold_left get_envs_from_top_decl (ty_env, ck_env) (consts_of_enum_type top_decl)
143
 | Open _           -> (ty_env, ck_env)
144

  
145
(* get type and clock environments from a header *)
146
let get_envs_from_top_decls header =
147
  List.fold_left get_envs_from_top_decl (Env.initial, Env.initial) header
148

  
149
(*
150
 List.fold_right
151
   (fun top_decl (ty_env, ck_env) ->
152
     match top_decl.top_decl_desc with
153
     | Node nd          -> (Env.add_value ty_env nd.node_id nd.node_type,
154
			    Env.add_value ck_env nd.node_id nd.node_clock)
155
     | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
156
			    Env.add_value ck_env ind.nodei_id ind.nodei_clock)
157
     | Const c          -> get_envs_from_const c (ty_env, ck_env)
158
     | TypeDef _        -> List.fold_left (fun envs top -> consts_of_enum_type top_decl
159
     | Open _           -> (ty_env, ck_env))
160
   header
161
   (Env.initial, Env.initial)
162
 *)
163

  
164
let check_compatibility (prog, computed_types_env, computed_clocks_env) (header, declared_types_env, declared_clocks_env) =
165
  try
166
    (* checking defined types are compatible with declared types*)
167
    Typing.check_typedef_compat header;
168

  
169
    (* checking type compatibility with computed types*)
170
    Typing.check_env_compat header declared_types_env computed_types_env;
171

  
172
    (* checking clocks compatibility with computed clocks*)
173
    Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
174

  
175
    (* checking stateless status compatibility *)
176
    Stateless.check_compat header
177
  with
178
  | (Types.Error (loc,err)) as exc ->
179
    eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@."
180
      Types.pp_error err;
181
    raise exc
182
  | Clocks.Error (loc, err) as exc ->
183
    eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a@."
184
      Clocks.pp_error err;
185
    raise exc
186
  | Stateless.Error (loc, err) as exc ->
187
    eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a@."
188
      Stateless.pp_error err;
189
    raise exc
190

  
191

  
192

  
193
let import_dependencies prog =
194
  Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. extracting dependencies@,");
195
  let dependencies = Corelang.get_dependencies prog in
196
  let deps =
197
  List.fold_left
198
    (fun (compilation_dep, type_env, clock_env) dep ->
199
      let (local, s) = Corelang.dependency_of_top dep in
200
      let basename = Modules.name_dependency (local, s) in
201
      Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@[<v 0>Library %s@," basename);
202
      let lusic = Modules.import_dependency dep.top_decl_loc (local, s) in
203
      Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@]@ ");
204
      let (lusi_type_env, lusi_clock_env) = get_envs_from_top_decls lusic.Lusic.contents in
205
      (local, s, lusic.Lusic.contents)::compilation_dep,
206
      Env.overwrite type_env lusi_type_env,
207
      Env.overwrite clock_env lusi_clock_env)
208
    ([], Basic_library.type_env, Basic_library.clock_env)
209
    dependencies in
210
  begin
211
    Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
212
    deps
213
  end
214

  
src/corelang.ml
28 28

  
29 29
let dummy_type_dec = {ty_dec_desc=Tydec_any; ty_dec_loc=Location.dummy_loc}
30 30

  
31

  
32

  
33 31
let dummy_clock_dec = {ck_dec_desc=Ckdec_any; ck_dec_loc=Location.dummy_loc}
34 32

  
35 33

  
......
87 85
    assert_expr = expr
88 86
  }
89 87

  
90
let mktop_decl loc d =
91
  { top_decl_desc = d; top_decl_loc = loc }
88
let mktop_decl loc own itf d =
89
  { top_decl_desc = d; top_decl_loc = loc; top_decl_owner = own; top_decl_itf = itf }
92 90

  
93 91
let mkpredef_call loc funname args =
94 92
  mkexpr loc (Expr_appl (funname, mkexpr loc (Expr_tuple args), None))
95 93

  
94

  
95
let const_of_top top_decl =
96
  match top_decl.top_decl_desc with
97
  | Const c -> c
98
  | _ -> assert false
99

  
100
let node_of_top top_decl =
101
  match top_decl.top_decl_desc with
102
  | Node nd -> nd
103
  | _ -> assert false
104

  
105
let imported_node_of_top top_decl =
106
  match top_decl.top_decl_desc with
107
  | ImportedNode ind -> ind
108
  | _ -> assert false
109

  
110
let typedef_of_top top_decl =
111
  match top_decl.top_decl_desc with
112
  | TypeDef tdef -> tdef
113
  | _ -> assert false
114

  
115
let dependency_of_top top_decl =
116
  match top_decl.top_decl_desc with
117
  | Open (local, dep) -> (local, dep)
118
  | _ -> assert false
119

  
120
let consts_of_enum_type top_decl =
121
  match top_decl.top_decl_desc with
122
  | TypeDef tdef ->
123
    (match tdef.tydef_desc with
124
     | Tydec_enum tags -> List.map (fun tag -> let cdecl = { const_id = tag; const_loc = top_decl.top_decl_loc; const_value = Const_tag tag; const_type = Type_predef.type_const tdef.tydef_id } in { top_decl with top_decl_desc = Const cdecl }) tags
125
     | _               -> [])
126
  | _ -> assert false
127

  
96 128
(************************************************************)
97 129
(*   Eexpr functions *)
98 130
(************************************************************)
......
142 174
let (node_table : (ident, top_decl) Hashtbl.t) = Hashtbl.create 30
143 175
let consts_table = Hashtbl.create 30
144 176

  
177
let print_node_table fmt () =
178
  begin
179
    Format.fprintf fmt "{ /* node table */@.";
180
    Hashtbl.iter (fun id nd ->
181
      Format.fprintf fmt "%s |-> %a"
182
	id
183
	Printers.pp_short_decl nd
184
    ) node_table;
185
    Format.fprintf fmt "}@."
186
  end
187

  
188
let print_consts_table fmt () =
189
  begin
190
    Format.fprintf fmt "{ /* consts table */@.";
191
    Hashtbl.iter (fun id const ->
192
      Format.fprintf fmt "%s |-> %a"
193
	id
194
	Printers.pp_const_decl (const_of_top const)
195
    ) consts_table;
196
    Format.fprintf fmt "}@."
197
  end
198

  
145 199
let node_name td =
146 200
    match td.top_decl_desc with 
147 201
    | Node nd         -> nd.node_id
......
174 228

  
175 229

  
176 230
(* alias and type definition table *)
231

  
232
let top_int_type = mktop_decl Location.dummy_loc Version.prefix false (TypeDef {tydef_id = "int"; tydef_desc = Tydec_int})
233
let top_bool_type = mktop_decl Location.dummy_loc Version.prefix false (TypeDef {tydef_id = "bool"; tydef_desc = Tydec_bool})
234
let top_float_type = mktop_decl Location.dummy_loc Version.prefix false (TypeDef {tydef_id = "float"; tydef_desc = Tydec_float})
235
let top_real_type = mktop_decl Location.dummy_loc Version.prefix false (TypeDef {tydef_id = "real"; tydef_desc = Tydec_real})
236

  
177 237
let type_table =
178 238
  Utils.create_hashtable 20 [
179
    Tydec_int  , Tydec_int;
180
    Tydec_bool , Tydec_bool;
181
    Tydec_float, Tydec_float;
182
    Tydec_real , Tydec_real
239
    Tydec_int  , top_int_type;
240
    Tydec_bool , top_bool_type;
241
    Tydec_float, top_float_type;
242
    Tydec_real , top_real_type
183 243
  ]
184 244

  
245
let print_type_table fmt () =
246
  begin
247
    Format.fprintf fmt "{ /* type table */@.";
248
    Hashtbl.iter (fun tydec tdef ->
249
      Format.fprintf fmt "%a |-> %a"
250
	Printers.pp_var_type_dec_desc tydec
251
	Printers.pp_typedef (typedef_of_top tdef)
252
    ) type_table;
253
    Format.fprintf fmt "}@."
254
  end
255

  
185 256
let rec is_user_type typ =
186 257
  match typ with
187 258
  | Tydec_int | Tydec_bool | Tydec_real 
......
190 261
  | _ -> true
191 262

  
192 263
let get_repr_type typ =
193
  let typ_def = Hashtbl.find type_table typ in
264
  let typ_def = (typedef_of_top (Hashtbl.find type_table typ)).tydef_desc in
194 265
  if is_user_type typ_def then typ else typ_def
195 266

  
196 267
let rec coretype_equal ty1 ty2 =
197
  (*let res =*) 
268
  let res =
198 269
  match ty1, ty2 with
199 270
  | Tydec_any           , _
200 271
  | _                   , Tydec_any             -> assert false
201 272
  | Tydec_const _       , Tydec_const _         -> get_repr_type ty1 = get_repr_type ty2
202
  | Tydec_const _       , _                     -> let ty1' = Hashtbl.find type_table ty1
273
  | Tydec_const _       , _                     -> let ty1' = (typedef_of_top (Hashtbl.find type_table ty1)).tydef_desc
203 274
	       					   in (not (is_user_type ty1')) && coretype_equal ty1' ty2
204 275
  | _                   , Tydec_const _         -> coretype_equal ty2 ty1
205 276
  | Tydec_int           , Tydec_int
......
215 286
      (List.sort (fun (f1,_) (f2,_) -> compare f1 f2) fl1)
216 287
      (List.sort (fun (f1,_) (f2,_) -> compare f1 f2) fl2)
217 288
  | _                                  -> false
218
  (*in (Format.eprintf "coretype_equal %a %a = %B@." Printers.pp_var_type_dec_desc ty1 Printers.pp_var_type_dec_desc ty2 res; res)*)
289
  in ((*Format.eprintf "coretype_equal %a %a = %B@." Printers.pp_var_type_dec_desc ty1 Printers.pp_var_type_dec_desc ty2 res;*) res)
219 290

  
220 291
let tag_true = "true"
221 292
let tag_false = "false"
......
262 333
(* To guarantee uniqueness of tags in enum types *)
263 334
let tag_table =
264 335
  Utils.create_hashtable 20 [
265
   tag_true, Tydec_bool;
266
   tag_false, Tydec_bool
336
   tag_true, top_bool_type;
337
   tag_false, top_bool_type
267 338
  ]
268 339

  
269 340
(* To guarantee uniqueness of fields in struct types *)
......
272 343
  ]
273 344

  
274 345
let get_enum_type_tags cty =
346
(*Format.eprintf "get_enum_type_tags %a@." Printers.pp_var_type_dec_desc cty;*)
275 347
 match cty with
276 348
 | Tydec_bool    -> [tag_true; tag_false]
277
 | Tydec_const _ -> (match Hashtbl.find type_table cty with
349
 | Tydec_const _ -> (match (typedef_of_top (Hashtbl.find type_table cty)).tydef_desc with
278 350
                     | Tydec_enum tl -> tl
279 351
                     | _             -> assert false)
280 352
 | _            -> assert false
281 353

  
282 354
let get_struct_type_fields cty =
283 355
 match cty with
284
 | Tydec_const _ -> (match Hashtbl.find type_table cty with
356
 | Tydec_const _ -> (match (typedef_of_top (Hashtbl.find type_table cty)).tydef_desc with
285 357
                     | Tydec_struct fl -> fl
286 358
                     | _               -> assert false)
287 359
 | _            -> assert false
......
403 475
  List.fold_left (
404 476
    fun nodes decl ->
405 477
      match decl.top_decl_desc with
406
	| Node nd -> nd::nodes
407
	| Consts _ | ImportedNode _ | Open _ | Type _ -> nodes  
478
	| Node _ -> decl::nodes
479
	| Const _ | ImportedNode _ | Open _ | TypeDef _ -> nodes  
408 480
  ) [] prog
409 481

  
410
let get_consts prog = 
482
let get_imported_nodes prog = 
411 483
  List.fold_left (
412
    fun consts decl ->
484
    fun nodes decl ->
413 485
      match decl.top_decl_desc with
414
	| Consts clist -> clist@consts
415
	| Node _ | ImportedNode _ | Open _ | Type _ -> consts  
486
	| ImportedNode _ -> decl::nodes
487
	| Const _ | Node _ | Open _ | TypeDef _-> nodes  
416 488
  ) [] prog
417 489

  
418
let get_types prog = 
419
  List.fold_left (
420
    fun types decl ->
490
let get_consts prog = 
491
  List.fold_right (
492
    fun decl consts ->
421 493
      match decl.top_decl_desc with
422
	| Type typ -> typ::types
423
	| Node _ | ImportedNode _ | Open _ | Consts _ -> types  
424
  ) [] prog
494
	| Const _ -> decl::consts
495
	| Node _ | ImportedNode _ | Open _ | TypeDef _ -> consts  
496
  ) prog []
497

  
498
let get_typedefs prog = 
499
  List.fold_right (
500
    fun decl types ->
501
      match decl.top_decl_desc with
502
	| TypeDef _ -> decl::types
503
	| Node _ | ImportedNode _ | Open _ | Const _ -> types  
504
  ) prog []
505

  
506
let get_dependencies prog =
507
  List.fold_right (
508
    fun decl deps ->
509
      match decl.top_decl_desc with
510
	| Open _ -> decl::deps
511
	| Node _ | ImportedNode _ | TypeDef _ | Const _ -> deps  
512
  ) prog []
425 513

  
426 514
let get_node_interface nd =
427 515
 {nodei_id = nd.node_id;
......
582 670
      (match top.top_decl_desc with
583 671
      | Node nd -> 
584 672
	{ top with top_decl_desc = Node (rename_node f_node f_var f_const nd) }
585
      | Consts c -> 
586
	{ top with top_decl_desc = Consts (List.map (rename_const f_const) c) }
673
      | Const c -> 
674
	{ top with top_decl_desc = Const (rename_const f_const c) }
587 675
      | ImportedNode _
588 676
      | Open _
589
      | Type _ -> top)
677
      | TypeDef _ -> top)
590 678
      ::accu
591 679
) [] prog
592 680
  )
......
604 692
    fprintf fmt "%s: " ind.nodei_id;
605 693
    Utils.reset_names ();
606 694
    fprintf fmt "%a@ " Types.print_ty ind.nodei_type
607
  | Consts _ | Open _ | Type _ -> ()
695
  | Const _ | Open _ | TypeDef _ -> ()
608 696

  
609 697
let pp_prog_type fmt tdecl_list =
610 698
  Utils.fprintf_list ~sep:"" pp_decl_type fmt tdecl_list
......
619 707
    fprintf fmt "%s: " ind.nodei_id;
620 708
    Utils.reset_names ();
621 709
    fprintf fmt "%a@ " Clocks.print_ck ind.nodei_clock
622
  | Consts _ | Open _ | Type _ -> ()
710
  | Const _ | Open _ | TypeDef _ -> ()
623 711

  
624 712
let pp_prog_clock fmt prog =
625 713
  Utils.fprintf_list ~sep:"" pp_decl_clock fmt prog
......
642 730
    fprintf fmt
643 731
      "%s is already defined.@."
644 732
      sym
733
  | Unknown_library sym ->
734
    fprintf fmt
735
      "impossible to load library %s.@."
736
      sym
645 737

  
646 738
(* filling node table with internal functions *)
647 739
let vdecls_of_typ_ck cpt ty =
......
659 751
  let (tin, tout) = Types.split_arrow ty in
660 752
  (*eprintf "internal fun %s: %d -> %d@." id (List.length (Types.type_list_of_type tin)) (List.length (Types.type_list_of_type tout));*)
661 753
  let cpt = ref (-1) in
662
  mktop_decl Location.dummy_loc
754
  mktop_decl Location.dummy_loc Version.prefix false
663 755
    (ImportedNode
664 756
       {nodei_id = id;
665 757
	nodei_type = ty;
src/corelang.mli
24 24
val mkexpr: Location.t ->  expr_desc -> expr
25 25
val mkeq: Location.t -> ident list * expr -> eq
26 26
val mkassert: Location.t -> expr -> assert_t
27
val mktop_decl: Location.t -> top_decl_desc -> top_decl
27
val mktop_decl: Location.t -> ident -> bool -> top_decl_desc -> top_decl
28 28
val mkpredef_call: Location.t -> ident -> expr list -> expr
29 29
val mk_new_name: var_decl list -> ident -> ident
30 30

  
31 31

  
32 32
val node_table : (ident, top_decl) Hashtbl.t
33
val print_node_table:  Format.formatter -> unit -> unit
33 34
val node_name: top_decl -> ident
34 35
val node_inputs: top_decl -> var_decl list
35 36
val node_from_name: ident -> top_decl
36 37
val is_generic_node: top_decl -> bool
37 38
val is_imported_node: top_decl -> bool
38 39

  
39
val consts_table: (ident, const_desc) Hashtbl.t
40
val type_table: (type_dec_desc, type_dec_desc) Hashtbl.t
40
val consts_table: (ident, top_decl) Hashtbl.t
41
val print_consts_table:  Format.formatter -> unit -> unit
42
val type_table: (type_dec_desc, top_decl) Hashtbl.t
43
val print_type_table:  Format.formatter -> unit -> unit
41 44
val get_repr_type: type_dec_desc -> type_dec_desc
42 45
val is_user_type: type_dec_desc -> bool
43 46
val coretype_equal: type_dec_desc -> type_dec_desc -> bool
44 47
val tag_true: label
45 48
val tag_false: label
46
val tag_table: (label, type_dec_desc) Hashtbl.t
47
val field_table: (label, type_dec_desc) Hashtbl.t
49
val tag_table: (label, top_decl) Hashtbl.t
50
val field_table: (label, top_decl) Hashtbl.t
48 51

  
49 52
val get_enum_type_tags: type_dec_desc -> label list
50 53

  
51 54
val get_struct_type_fields: type_dec_desc -> (label * type_dec_desc) list
52 55

  
56
val consts_of_enum_type: top_decl -> top_decl list
57

  
53 58
val const_of_bool: bool -> constant
54 59
val const_is_bool: constant -> bool
55 60
val const_negation: constant -> constant
......
90 95

  
91 96
val pp_prog_clock : Format.formatter -> program -> unit
92 97

  
93
val get_nodes : program -> node_desc list
94
 val get_consts : program -> const_desc list 
98
val const_of_top: top_decl -> const_desc
99
val node_of_top: top_decl -> node_desc
100
val imported_node_of_top: top_decl -> imported_node_desc
101
val typedef_of_top: top_decl -> typedef_desc
102
val dependency_of_top: top_decl -> (bool * ident)
103

  
104
val get_nodes : program -> top_decl list
105
val get_imported_nodes : program -> top_decl list
106
val get_consts : program -> top_decl list
107
val get_typedefs: program -> top_decl list
108
val get_dependencies : program -> top_decl list
95 109
(* val prog_unfold_consts: program -> program *)
96 110

  
97 111
val expr_replace_var: (ident -> ident) -> expr -> expr
src/delay_predef.ml
17 17
let delay_un =
18 18
  new_delay Dundef
19 19

  
20
let delay_nullary_poly_op =
21
  let univ = new_univar () in
22
  univ
23

  
20 24
let delay_unary_poly_op =
21 25
  let univ = new_univar () in
22 26
  new_delay (Darrow (univ, univ))
src/inliner.ml
279 279
    node_annot = [];
280 280
  }
281 281
  in
282
  let main = [{ top_decl_desc = Node main_node; top_decl_loc = loc }] in
282
  let main = [{ top_decl_desc = Node main_node; top_decl_loc = loc; top_decl_owner = filename; top_decl_itf = false }] in
283 283
  let new_prog = others@nodes_origs@nodes_inlined@main in
284 284
  let _ = Typing.type_prog type_env new_prog in
285 285
  let _ = Clock_calculus.clock_prog clock_env new_prog in
src/lexer_lustre.mll
53 53
  "clock", TCLOCK;
54 54
  "not", NOT;
55 55
  "tail", TAIL;
56
  "true", TRUE;
57
  "false", FALSE;
56 58
  "and", AND;
57 59
  "or", OR;
58 60
  "xor", XOR;
......
114 116
| "tel." {TEL}
115 117
| "tel;" {TEL}
116 118
| "#open" { OPEN }
117
| ['_' 'a'-'z' 'A'-'Z'] [ '_' 'a'-'z' 'A'-'Z' '0'-'9']*
119
| ['_' 'a'-'z'] [ '_' 'a'-'z' 'A'-'Z' '0'-'9']*
118 120
    {let s = Lexing.lexeme lexbuf in
119 121
    try
120 122
      Hashtbl.find keyword_table s
121 123
    with Not_found ->
122 124
      IDENT s}
125
| ['A'-'Z'] [ '_' 'a'-'z' 'A'-'Z' '0'-'9']*
126
    {let s = Lexing.lexeme lexbuf in
127
    try
128
      Hashtbl.find keyword_table s
129
    with Not_found ->
130
      UIDENT s}
123 131
| "->" {ARROW}
124 132
| "=>" {IMPL}
125 133
| "<=" {LTE}
src/liveness.ml
65 65
    (ISet.union outputs mems)
66 66
    (ISet.union inputs mems)
67 67

  
68
(* checks whether a variable is aliasable,
69
   depending on its (address) type *)
70
let is_aliasable var =
71
 Types.is_address_type var.var_type
72

  
73 68
(* computes the set of potentially reusable variables.
74 69
   We don't reuse input variables, due to possible aliasing *)
75 70
let node_reusable_variables node =
src/location.ml
10 10
(********************************************************************)
11 11

  
12 12
type t = { loc_start: Lexing.position; loc_end: Lexing.position }
13

  
14
type filename = string
15

  
13 16
let dummy_loc = {loc_start=Lexing.dummy_pos; loc_end=Lexing.dummy_pos}
14 17

  
15
let input_name = ref ""
18
let set_input, get_input, get_module =
19
  let input_name : filename ref = ref "__UNINITIALIZED__" in
20
  let module_name : filename ref = ref "__UNINITIALIZED__" in
21
  (fun name -> input_name := name; module_name := Filename.chop_extension name),
22
  (fun () -> !input_name),
23
  (fun () -> !module_name)
16 24

  
17 25
let curr lexbuf = {
18 26
  loc_start = lexbuf.Lexing.lex_start_p;
src/lusic.ml
1

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

  
13
open Format 
14
open LustreSpec
15
open Corelang
16

  
... This diff was truncated because it exceeds the maximum size that can be displayed.

Also available in: Unified diff