Project

General

Profile

Revision b1655a21

View differences:

src/clock_calculus.ml
846 846
    clock_imported_node env decl.top_decl_loc nd
847 847
  | Consts clist ->
848 848
    clock_top_consts env clist
849
  | Open _ ->
850
    env
849
  | Open _
850
  | Type _ -> env
851 851

  
852 852
let clock_prog env decls =
853 853
  List.fold_left (fun e decl -> clock_top_decl e decl) env decls
......
878 878
      uneval_node_generics (nd.node_inputs @ nd.node_locals @ nd.node_outputs)
879 879
  | ImportedNode nd ->
880 880
      uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
881
  | Consts clist -> ()
882
  | Open _  -> ()
881
  | Consts _
882
  | Open _
883
  | Type _   -> ()
883 884

  
884 885
let uneval_prog_generics prog =
885 886
 List.iter uneval_top_generics prog
src/corelang.ml
193 193
  let typ_def = Hashtbl.find type_table typ in
194 194
  if is_user_type typ_def then typ else typ_def
195 195

  
196
let rec coretype_equal ty1 ty2 =
197
  let res = 
198
  match ty1, ty2 with
199
  | Tydec_any       , _
200
  | _               , Tydec_any        -> assert false
201
  | Tydec_const _   , Tydec_const _    -> get_repr_type ty1 = get_repr_type ty2
202
  | Tydec_const _   , _                -> let ty1' = Hashtbl.find type_table ty1
203
					  in (not (is_user_type ty1')) && coretype_equal ty1' ty2
204
  | _               , Tydec_const _    -> coretype_equal ty2 ty1
205
  | Tydec_int       , Tydec_int
206
  | Tydec_real      , Tydec_real
207
  | Tydec_float     , Tydec_float
208
  | Tydec_bool      , Tydec_bool       -> true
209
  | Tydec_clock ty1 , Tydec_clock ty2  -> coretype_equal ty1 ty2
210
  | Tydec_enum tl1  , Tydec_enum tl2   -> List.sort compare tl1 = List.sort compare tl2
211
  | Tydec_struct fl1, Tydec_struct fl2 ->
212
       List.length fl1 = List.length fl2
213
    && List.for_all2 (fun (f1, t1) (f2, t2) -> f1 = f2 && coretype_equal t1 t2)
214
      (List.sort (fun (f1,_) (f2,_) -> compare f1 f2) fl1)
215
      (List.sort (fun (f1,_) (f2,_) -> compare f1 f2) fl2)
216
  | _                                  -> false
217
  in ((*Format.eprint "coretype_equal %a %a = %B@." Printers.pp_var_type_dec_desc ty1 Printers.pp_var_type_dec_desc ty2 res;*) res)
218

  
196 219
let tag_true = "true"
197 220
let tag_false = "false"
198 221

  
......
380 403
    fun nodes decl ->
381 404
      match decl.top_decl_desc with
382 405
	| Node nd -> nd::nodes
383
	| Consts _ | ImportedNode _ | Open _ -> nodes  
406
	| Consts _ | ImportedNode _ | Open _ | Type _ -> nodes  
384 407
  ) [] prog
385 408

  
386 409
let get_consts prog = 
......
388 411
    fun consts decl ->
389 412
      match decl.top_decl_desc with
390 413
	| Consts clist -> clist@consts
391
	| Node _ | ImportedNode _ | Open _ -> consts  
414
	| Node _ | ImportedNode _ | Open _ | Type _ -> consts  
392 415
  ) [] prog
393 416

  
394

  
417
let get_types prog = 
418
  List.fold_left (
419
    fun types decl ->
420
      match decl.top_decl_desc with
421
	| Type typ -> typ::types
422
	| Node _ | ImportedNode _ | Open _ | Consts _ -> types  
423
  ) [] prog
395 424

  
396 425
(************************************************************************)
397 426
(*        Renaming                                                      *)
......
543 572
      | Consts c -> 
544 573
	{ top with top_decl_desc = Consts (List.map (rename_const f_const) c) }
545 574
      | ImportedNode _
546
      | Open _ -> top)
575
      | Open _
576
      | Type _ -> top)
547 577
      ::accu
548 578
) [] prog
549 579
  )
......
561 591
    fprintf fmt "%s: " ind.nodei_id;
562 592
    Utils.reset_names ();
563 593
    fprintf fmt "%a@ " Types.print_ty ind.nodei_type
564
  | Consts _ | Open _ -> ()
594
  | Consts _ | Open _ | Type _ -> ()
565 595

  
566 596
let pp_prog_type fmt tdecl_list =
567 597
  Utils.fprintf_list ~sep:"" pp_decl_type fmt tdecl_list
......
576 606
    fprintf fmt "%s: " ind.nodei_id;
577 607
    Utils.reset_names ();
578 608
    fprintf fmt "%a@ " Clocks.print_ck ind.nodei_clock
579
  | Consts _ | Open _ -> ()
609
  | Consts _ | Open _ | Type _ -> ()
580 610

  
581 611
let pp_prog_clock fmt prog =
582 612
  Utils.fprintf_list ~sep:"" pp_decl_clock fmt prog
src/corelang.mli
40 40
val type_table: (type_dec_desc, type_dec_desc) Hashtbl.t
41 41
val get_repr_type: type_dec_desc -> type_dec_desc
42 42
val is_user_type: type_dec_desc -> bool
43
val coretype_equal: type_dec_desc -> type_dec_desc -> bool
43 44
val tag_true: label
44 45
val tag_false: label
45 46
val tag_table: (label, type_dec_desc) Hashtbl.t
src/dimension.ml
124 124
    f1 = f2 && List.length args1 = List.length args2 && List.for_all2 is_eq_dimension args1 args2
125 125
  | Dite (c1, t1, e1), Dite (c2, t2, e2) ->
126 126
    is_eq_dimension c1 c2 && is_eq_dimension t1 t2 && is_eq_dimension e1 e2
127
  | Dvar, _
128
  | _, Dvar
129
  | Dunivar, _
130
  | _, Dunivar -> false
131
  | _ -> d1 = d2
127
  | Dint i1   , Dint i2    -> i1 = i2
128
  | Dbool b1  , Dbool b2   -> b1 = b2
129
  | Dident id1, Dident id2 -> id1 = id2
130
  | _                      -> false
132 131

  
133 132
let is_dimension_const dim =
134 133
 match (repr dim).dim_desc with
src/lustreSpec.ml
32 32
  | Tydec_struct of (ident * type_dec_desc) list
33 33
  | Tydec_array of Dimension.dim_expr * type_dec_desc
34 34

  
35
type type_def =
36
  {
37
    ty_def_id: ident;
38
    ty_def_desc: type_dec_desc}
39

  
35 40
type clock_dec =
36 41
    {ck_dec_desc: clock_dec_desc;
37 42
     ck_dec_loc: Location.t}
......
173 178
| ImportedNode of imported_node_desc
174 179
| Open of bool * string (* the boolean set to true denotes a local 
175 180
			   lusi vs a lusi installed at system level *)
181
| Type of type_def
176 182

  
177 183
type top_decl =
178 184
    {top_decl_desc: top_decl_desc;
src/main_lustre_compiler.ml
75 75
      Parse.report_error err;
76 76
      raise exc
77 77
    | Corelang.Error (loc, err) as exc -> (
78
      eprintf "Parsing error %a%a@."
78
      eprintf "Parsing error: %a%a@."
79 79
	Corelang.pp_error err
80 80
	Location.pp_loc loc;
81 81
      raise exc
......
93 93
    let header = load_lusi true lusi_name in
94 94
    let _, declared_types_env, declared_clocks_env = check_lusi header in
95 95
        
96
   (* checking defined types are compatible with declared types*)
97
    Typing.check_typedef_compat header;
96 98

  
97 99
    (* checking type compatibility with computed types*)
98 100
    Typing.check_env_compat header declared_types_env computed_types_env;
......
289 291
      end
290 292
    else
291 293
      machine_code
294
 in  
295
  let machine_code = 
296
    if !Options.optimization >= 3 && !Options.output <> "horn" then
297
      begin
298
	Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization@,");
299
	Optimize_machine.machines_fusion machine_code
300
      end
301
    else
302
      machine_code
292 303
 in
293 304
  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"
294 305
  (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
src/normalization.ml
401 401
  match decl.top_decl_desc with
402 402
  | Node nd ->
403 403
    {decl with top_decl_desc = Node (normalize_node nd)}
404
  | Open _ | ImportedNode _ | Consts _ -> decl
404
  | Open _ | ImportedNode _ | Consts _ | Type _ -> decl
405 405
  
406 406
let normalize_prog decls = 
407 407
  List.map normalize_decl decls
src/optimize_machine.ml
11 11

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

  
16 17
let rec eliminate elim instr =
......
201 202
      machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table
202 203
    ) prog
203 204

  
205
let rec instr_assign res instr =
206
  match instr with
207
  | MLocalAssign (i, _) -> Disjunction.CISet.add i res
208
  | MStateAssign (i, _) -> Disjunction.CISet.add i res
209
  | MBranch (g, hl)     -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl
210
  | MStep (il, _, _)    -> List.fold_right Disjunction.CISet.add il res
211
  | _                   -> res
212

  
213
and instrs_assign res instrs =
214
  List.fold_left instr_assign res instrs
215

  
216
let rec instr_constant_assign var instr =
217
  match instr with
218
  | MLocalAssign (i, Cst (Const_tag _))
219
  | MStateAssign (i, Cst (Const_tag _)) -> i = var
220
  | MBranch (g, hl)                     -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl
221
  | _                                   -> false
222

  
223
and instrs_constant_assign var instrs =
224
  List.fold_left (fun res i -> if Disjunction.CISet.mem var (instr_assign Disjunction.CISet.empty i) then instr_constant_assign var i else res) false instrs
225

  
226
let rec instr_reduce branches instr1 cont =
227
  match instr1 with
228
  | MLocalAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont)
229
  | MStateAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont)
230
  | MBranch (g, hl)                     -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont
231
  | _                                   -> instr1 :: cont
232

  
233
and instrs_reduce branches instrs cont =
234
 match instrs with
235
 | []        -> cont
236
 | [i]       -> instr_reduce branches i cont
237
 | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont
238

  
239
let rec instrs_fusion instrs =
240
  match instrs with
241
  | []
242
  | [_]                                                               ->
243
    instrs
244
  | i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 ->
245
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
246
  | i1::(MBranch (StateVar v, hl))::q when instr_constant_assign v i1 ->
247
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) 
248
  | i1::i2::q                                                         ->
249
    i1 :: instrs_fusion (i2::q)
250

  
251
let step_fusion step =
252
  { step with
253
    step_instrs = instrs_fusion step.step_instrs;
254
  }
255

  
256
let rec machine_fusion m =
257
  { m with
258
    mstep = step_fusion m.mstep
259
  }
260

  
261
let machines_fusion prog =
262
  List.map machine_fusion prog
204 263

  
205 264
(* Local Variables: *)
206 265
(* compile-command:"make -C .." *)
src/parse.ml
12 12
exception Syntax_err of Location.t
13 13

  
14 14
open Format
15
open LustreSpec
16
open Corelang
17

  
18
let add_symbol loc msg hashtbl name value =
19
 if Hashtbl.mem hashtbl name
20
 then raise (Error (loc, Already_bound_symbol msg))
21
 else Hashtbl.add hashtbl name value
22

  
23
let check_symbol loc msg hashtbl name =
24
 if not (Hashtbl.mem hashtbl name)
25
 then raise (Error (loc, Unbound_symbol msg))
26
 else ()
27

  
28
let add_node own name value =
29
  try
30
    match (Hashtbl.find node_table name).top_decl_desc, value.top_decl_desc with
31
    | Node _        , ImportedNode _ when own   -> ()
32
    | ImportedNode _, _                         -> Hashtbl.add node_table name value
33
    | Node _        , _                         -> raise (Error (value.top_decl_loc, Already_bound_symbol ("node " ^ name)))
34
    | _                                         -> assert false
35
  with
36
    Not_found                                   -> Hashtbl.add node_table name value
37

  
38

  
39
let add_tag loc own name typ =
40
  if Hashtbl.mem tag_table name && (not own) then
41
    raise (Error (loc, Unbound_symbol ("enum tag " ^ name)))
42
  else Hashtbl.add tag_table name typ
43

  
44
let add_field loc own name typ =
45
  if Hashtbl.mem field_table name && (not own) then
46
    raise (Error (loc, Unbound_symbol ("struct field " ^ name)))
47
  else Hashtbl.add field_table name typ
48

  
49
let rec check_type_def loc own name ty =
50
  match ty with
51
  | Tydec_enum tl   ->
52
    begin
53
      List.iter (fun tag -> add_tag loc own tag (Tydec_const name)) tl;
54
      ty
55
    end
56
  | Tydec_struct fl -> 
57
    begin
58
      List.iter (fun (field, _) -> add_field loc own field (Tydec_const name)) fl;
59
      Tydec_struct (List.map (fun (f, ty) -> (f, check_type_def loc own name ty)) fl)
60
    end
61
  | Tydec_clock ty      -> Tydec_clock (check_type_def loc own name ty)
62
  | Tydec_const c       ->
63
    if not (Hashtbl.mem type_table (Tydec_const c))
64
    then raise (Error (loc, Unbound_symbol ("type " ^ c)))
65
    else get_repr_type ty
66
  | Tydec_array (c, ty) -> Tydec_array (c, check_type_def loc own name ty)
67
  | _                   -> ty
68

  
69
let add_type own name value =
70
(*Format.eprintf "add_type %B %s@." own name;*)
71
  match value.top_decl_desc with
72
  | Type ty ->
73
    let loc = value.top_decl_loc in
74
    if Hashtbl.mem type_table (Tydec_const name) && (not own)
75
    then raise (Error (loc, Already_bound_symbol ("type " ^ name)))
76
    else Hashtbl.add type_table (Tydec_const name) (check_type_def loc own name ty.ty_def_desc)
77
  | _       -> assert false
78

  
79
let check_type loc name =
80
 if not (Hashtbl.mem type_table (Tydec_const name))
81
 then raise (Error (loc, Unbound_symbol ("type " ^ name)))
82
 else ()
15 83

  
16 84
let report_error loc =
17 85
  Location.print loc;
src/parser_lustre.mly
10 10
/********************************************************************/
11 11

  
12 12
%{
13
open Utils
13 14
open LustreSpec
14 15
open Corelang
15 16
open Dimension
16
open Utils
17
open Parse
17 18

  
18 19
let get_loc () = Location.symbol_rloc ()
19 20
let mktyp x = mktyp (get_loc ()) x
......
35 36

  
36 37
let mkannots annots = { annots = annots; annot_loc = get_loc () }
37 38

  
38
let add_node loc own msg hashtbl name value =
39
  try
40
    match (Hashtbl.find hashtbl name).top_decl_desc, value.top_decl_desc with
41
    | Node _        , ImportedNode _ when own   -> ()
42
    | ImportedNode _, _                         -> Hashtbl.add hashtbl name value
43
    | Node _        , _                         -> raise (Error (loc, Already_bound_symbol msg))
44
    | _                                         -> assert false
45
  with
46
    Not_found                                   -> Hashtbl.add hashtbl name value
47

  
48

  
49
let add_symbol loc msg hashtbl name value =
50
 if Hashtbl.mem hashtbl name
51
 then raise (Error (loc, Already_bound_symbol msg))
52
 else Hashtbl.add hashtbl name value
53

  
54
let check_symbol loc msg hashtbl name =
55
 if not (Hashtbl.mem hashtbl name)
56
 then raise (Error (loc, Unbound_symbol msg))
57
 else ()
58

  
59
let check_node_symbol msg name value =
60
 if Hashtbl.mem node_table name
61
 then () (* TODO: should we check the types here ? *)
62
 else Hashtbl.add node_table name value
63

  
64 39
%}
65 40

  
66 41
%token <int> INT
......
128 103
%%
129 104

  
130 105
prog:
131
 open_list typ_def_list top_decl_list EOF { $1 @ (List.rev $3) }
106
 open_list typ_def_prog top_decl_list EOF { $1 @ $2 @ (List.rev $3) }
107

  
108
typ_def_prog:
109
 typ_def_list { $1 true }
132 110

  
133 111
header:
134
 open_list typ_def_list top_decl_header_list EOF { (fun own -> ($1 @ (List.rev ($3 own)))) }
112
 open_list typ_def_list top_decl_header_list EOF { (fun own -> ($1 @ let typs = $2 own in typs @ (List.rev ($3 own)))) }
135 113

  
136 114
open_list:
137 115
  { [] }
......
142 120
| OPEN LT IDENT GT { mktop_decl (Open (false, $3)) }
143 121

  
144 122
top_decl_list:
145
  top_decl {[$1]}
123
   {[]}
146 124
| top_decl_list top_decl {$2::$1}
147 125

  
148 126

  
149 127
top_decl_header_list:
150
  top_decl_header {(fun own -> [$1 own]) }
151
| top_decl_header_list top_decl_header {(fun own -> ($2 own)::($1 own)) }
128
   {(fun own -> []) }
129
| top_decl_header_list top_decl_header {(fun own -> let h1 = $1 own in ($2 own)::h1) }
152 130

  
153 131
state_annot:
154 132
  FUNCTION { true }
......
168 146
			     nodei_prototype = $13;
169 147
			     nodei_in_lib = $14;})
170 148
    in
171
     check_node_symbol ("node " ^ $3) $3 nd; 
172
     let loc = get_loc () in
173
     (fun own -> add_node loc own ("node " ^ $3) node_table $3 nd; nd) }
149
     (fun own -> add_node own $3 nd; nd) }
174 150

  
175 151
prototype_opt:
176 152
 { None }
......
200 176
			     node_spec = $1;
201 177
			     node_annot = annots})
202 178
     in
203
     let loc = Location.symbol_rloc () in
204
     add_node loc true ("node " ^ $3) node_table $3 nd; nd}
179
     add_node true $3 nd; nd}
205 180

  
206 181
nodespec_list:
207 182
 { None }
......
211 186
  | Some s2 -> (fun s1 -> Some (merge_node_annot s1 s2))) $2 $1 }
212 187

  
213 188
typ_def_list:
214
    /* empty */ {}
215
| typ_def SCOL typ_def_list {$1;$3}
189
    /* empty */             { (fun own -> []) }
190
| typ_def SCOL typ_def_list { (fun own -> let ty1 = ($1 own) in ty1 :: ($3 own)) }
216 191

  
217 192
typ_def:
218
  TYPE IDENT EQ typeconst {
219
    try
220
      let loc = Location.symbol_rloc () in
221
      add_symbol loc ("type " ^ $2) type_table (Tydec_const $2) (get_repr_type $4)
222
    with Not_found-> assert false }
223
| TYPE IDENT EQ ENUM LCUR tag_list RCUR { Hashtbl.add type_table (Tydec_const $2) (Tydec_enum ($6 (Tydec_const $2))) }
224
| TYPE IDENT EQ STRUCT LCUR field_list RCUR { Hashtbl.add type_table (Tydec_const $2) (Tydec_struct ($6 (Tydec_const $2))) }
193
  TYPE IDENT EQ typ_def_rhs { let typ = mktop_decl (Type { ty_def_id = $2;
194
							   ty_def_desc = $4
195
							 })
196
			      in (fun own -> add_type own $2 typ; typ) }
197

  
198
typ_def_rhs:
199
  typeconst                   { $1 }
200
| ENUM LCUR tag_list RCUR     { Tydec_enum (List.rev $3) }
201
| STRUCT LCUR field_list RCUR { Tydec_struct (List.rev $3) }
225 202

  
226 203
array_typ_decl:
227 204
                            { fun typ -> typ }
228 205
 | POWER dim array_typ_decl { fun typ -> $3 (Tydec_array ($2, typ)) }
229 206

  
230 207
typeconst:
231
  TINT array_typ_decl  { $2 Tydec_int }
232
| TBOOL array_typ_decl { $2 Tydec_bool  }
233
| TREAL array_typ_decl { $2 Tydec_real  }
208
  TINT array_typ_decl   { $2 Tydec_int }
209
| TBOOL array_typ_decl  { $2 Tydec_bool  }
210
| TREAL array_typ_decl  { $2 Tydec_real  }
234 211
| TFLOAT array_typ_decl { $2 Tydec_float }
235
| IDENT array_typ_decl { 
236
        let loc = Location.symbol_rloc () in
237
	check_symbol loc ("type " ^ $1) type_table (Tydec_const $1); $2 (Tydec_const $1) }
238
| TBOOL TCLOCK  { Tydec_clock Tydec_bool }
239
| IDENT TCLOCK  { Tydec_clock (Tydec_const $1) }
212
| IDENT array_typ_decl  { $2 (Tydec_const $1) }
213
| TBOOL TCLOCK          { Tydec_clock Tydec_bool }
214
| IDENT TCLOCK          { Tydec_clock (Tydec_const $1) }
240 215

  
241 216
tag_list:
242
  IDENT
243
  { let loc = Location.symbol_rloc () in 
244
    (fun t -> 
245
      add_symbol loc ("tag " ^ $1) tag_table $1 t; $1 :: []) }
246
| tag_list COMMA IDENT
247
      {       
248
	let loc = Location.symbol_rloc () in
249
	(fun t -> add_symbol loc ("tag " ^ $3)tag_table $3 t; $3 :: ($1 t)) 
250
      }
217
  IDENT                { $1 :: [] }
218
| tag_list COMMA IDENT { $3 :: $1 }
251 219
      
252
field_list:
253
  { (fun t -> []) }
254
| field_list IDENT COL typeconst SCOL
255
      {
256
	let loc = Location.symbol_rloc () in
257
	(fun t -> add_symbol loc ("field " ^ $2) field_table $2 t; ($1 t) @ [ ($2, $4) ]) }
220
field_list:                           { [] }
221
| field_list IDENT COL typeconst SCOL { ($2, $4) :: $1 }
258 222
      
259 223
eq_list:
260 224
  { [], [], [] }
src/printers.ml
9 9
(*                                                                  *)
10 10
(********************************************************************)
11 11

  
12
open Corelang
13 12
open LustreSpec
14 13
open Format
15 14
open Utils
......
192 191
    pp_eq_lhs eq.eq_lhs
193 192
    pp_expr eq.eq_rhs
194 193

  
195
let pp_node_eqs = fprintf_list ~sep:"@ " pp_node_eq 
194
let pp_node_eqs = fprintf_list ~sep:"@ " pp_node_eq
196 195

  
196
let rec pp_var_struct_type_field fmt (label, tdesc) =
197
  fprintf fmt "%a : %a;" pp_print_string label pp_var_type_dec_desc tdesc
198
and pp_var_type_dec_desc fmt tdesc =
199
  match tdesc with 
200
  | Tydec_any -> fprintf fmt "<any>"
201
  | Tydec_int -> fprintf fmt "int"
202
  | Tydec_real -> fprintf fmt "real"
203
  | Tydec_float -> fprintf fmt "float"
204
  | Tydec_bool -> fprintf fmt "bool"
205
  | Tydec_clock t -> fprintf fmt "%a clock" pp_var_type_dec_desc t
206
  | Tydec_const t -> fprintf fmt "%s" t
207
  | Tydec_enum id_list -> fprintf fmt "enum {%a }" (fprintf_list ~sep:", " pp_print_string) id_list
208
  | Tydec_struct f_list -> fprintf fmt "struct {%a }" (fprintf_list ~sep:" " pp_var_struct_type_field) f_list
209
  | Tydec_array (s, t) -> fprintf fmt "%a^%a" pp_var_type_dec_desc t Dimension.pp_dimension s
197 210

  
198 211
let pp_var_type_dec fmt ty =
199
  let rec pp_var_struct_type_field fmt (label, tdesc) =
200
    fprintf fmt "%a : %a" pp_var_type_dec_desc tdesc pp_print_string label
201
  and pp_var_type_dec_desc fmt tdesc =
202
  match tdesc with 
203
    | Tydec_any -> fprintf fmt "<any>"
204
    | Tydec_int -> fprintf fmt "int"
205
    | Tydec_real -> fprintf fmt "real"
206
    | Tydec_float -> fprintf fmt "float"
207
    | Tydec_bool -> fprintf fmt "bool"
208
    | Tydec_clock t -> fprintf fmt "%a clock" pp_var_type_dec_desc t
209
    | Tydec_const t -> fprintf fmt "%s" t
210
    | Tydec_enum id_list -> fprintf fmt "enum {%a }" (fprintf_list ~sep:", " pp_print_string) id_list
211
    | Tydec_struct f_list -> fprintf fmt "struct {%a }" (fprintf_list ~sep:"; " pp_var_struct_type_field) f_list
212
    | Tydec_array (s, t) -> fprintf fmt "%a^%a" pp_var_type_dec_desc t Dimension.pp_dimension s
213
in pp_var_type_dec_desc fmt ty.ty_dec_desc
212
  pp_var_type_dec_desc fmt ty.ty_dec_desc
213

  
214
let pp_type_def fmt ty =
215
  fprintf fmt "type %s = %a;@ " ty.ty_def_id pp_var_type_dec_desc ty.ty_def_desc
214 216

  
215 217
(* let rec pp_var_type fmt ty =  *)
216 218
(*   fprintf fmt "%a" (match ty.tdesc with  *)
......
295 297
  | ImportedNode ind ->
296 298
    fprintf fmt "imported %a;@ " pp_imported_node ind
297 299
  | Consts clist -> (fprintf fmt "const %a@ " pp_const_list clist)
298
  | Open (local, s) -> if local then fprintf fmt "open \"%s\"" s else fprintf fmt "open <%s>" s
299

  
300
  | Open (local, s) -> if local then fprintf fmt "open \"%s\"@ " s else fprintf fmt "open <%s>@ " s
301
  | Type tdef -> fprintf fmt "%a@ " pp_type_def tdef
300 302

  
301 303
let pp_prog fmt prog = 
302 304
  fprintf_list ~sep:"@ " pp_decl fmt prog
......
306 308
  | Node nd -> fprintf fmt "node %s@ " nd.node_id
307 309
  | ImportedNode ind -> fprintf fmt "imported node %s" ind.nodei_id
308 310
  | Consts clist -> (fprintf fmt "const %a@ " pp_const_list clist)
309
    | Open (local, s) -> if local then fprintf fmt "open \"%s\"" s else fprintf fmt "open <%s>" s
311
  | Open (local, s) -> if local then fprintf fmt "open \"%s\"@ " s else fprintf fmt "open <%s>@ " s
312
  | Type tdef -> fprintf fmt "type %s;@ " tdef.ty_def_id
310 313

  
311 314
let pp_lusi fmt decl = 
312 315
  match decl.top_decl_desc with
......
318 321
      pp_node_args nd.node_inputs
319 322
      pp_node_args nd.node_outputs
320 323
| Consts clist -> (fprintf fmt "const %a@ " pp_const_list clist)
321
| ImportedNode _ | Open _ -> ()
322

  
323

  
324

  
324
| Open (local, s) -> if local then fprintf fmt "open \"%s\"@ " s else fprintf fmt "open <%s>@ " s
325
| Type tdef -> fprintf fmt "%a@ " pp_type_def tdef
326
| ImportedNode _ -> ()
325 327

  
326 328
let pp_lusi_header fmt filename prog =
327 329
  fprintf fmt "(* Generated Lustre Interface file from %s *)@." filename;
328
  fprintf fmt "(* generated by Lustre-C compiler version %s, %a *)@." Version.number pp_date (Unix.gmtime (Unix.time ()));
329
  fprintf fmt "(* feel free to mask some of the nodes by removing them from this file. *)@.@.";
330
  fprintf fmt "(* by Lustre-C compiler version %s, %a *)@." Version.number pp_date (Unix.gmtime (Unix.time ()));
331
  fprintf fmt "(* Feel free to mask some of the definitions by removing them from this file. *)@.@.";
330 332
  List.iter (fprintf fmt "%a@." pp_lusi) prog    
331 333
  
332 334
(* Local Variables: *)
src/scheduling.ml
30 30
(* Topological sort with a priority for variables belonging in the same equation lhs.
31 31
   For variables still unrelated, standard compare is used to choose the minimal element.
32 32
   This priority is used since it helps a lot in factorizing generated code.
33
   Moreover, the dependency graph is browsed in a depth-first manner whenever possible,
34
   to improve the behavior of optimization algorithms applied in forthcoming compilation steps. 
33 35
   In the following functions:
34 36
   - [eq_equiv] is the equivalence relation between vars of the same equation lhs
35 37
   - [g] the (imperative) graph to be topologically sorted
src/types.ml
49 49
  | Assigned_constant of ident
50 50
  | WrongArity of int * int
51 51
  | WrongMorphism of int * int
52
  | Type_mismatch of ident
52 53
  | Type_clash of type_expr * type_expr
53 54
  | Poly_imported_node of ident
54 55

  
......
155 156
    fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2
156 157
  | WrongMorphism (ar1, ar2) ->
157 158
    fprintf fmt "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2
159
  | Type_mismatch id ->
160
    fprintf fmt "Definition and declaration of type %s don't agree@." id
158 161
  | Undefined_var vmap ->
159 162
    fprintf fmt "No definition provided for variable(s): %a@."
160 163
      (Utils.fprintf_list ~sep:"," pp_print_string)
src/typing.ml
670 670
      type_imported_node env nd decl.top_decl_loc
671 671
  | Consts clist ->
672 672
      type_top_consts env clist
673
  | Type _
673 674
  | Open _  -> env
674 675

  
675 676
let type_prog env decls =
......
701 702
      uneval_node_generics (nd.node_inputs @ nd.node_outputs)
702 703
  | ImportedNode nd ->
703 704
      uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
704
  | Consts clist -> ()
705
  | Consts _
706
  | Type _
705 707
  | Open _  -> ()
706 708

  
707 709
let uneval_prog_generics prog =
......
727 729
    Types.print_ty Format.std_formatter computed_t;*)
728 730
    try_unify ~sub:true ~semi:true decl_type_k computed_t Location.dummy_loc
729 731
		    )
732
let check_typedef_top decl =
733
  match decl.top_decl_desc with
734
  | Type ty ->
735
Format.eprintf "check_typedef %a %a@." Printers.pp_var_type_dec_desc ty.ty_def_desc Printers.pp_var_type_dec_desc (Hashtbl.find type_table (Tydec_const ty.ty_def_id));
736
    if coretype_equal ty.ty_def_desc (Hashtbl.find type_table (Tydec_const ty.ty_def_id)) then ()
737
    else raise (Error (decl.top_decl_loc, Type_mismatch ty.ty_def_id))
738
  | _  -> ()
739

  
740
let check_typedef_compat header =
741
  List.iter check_typedef_top header
730 742

  
731 743
(* Local Variables: *)
732 744
(* compile-command:"make -C .." *)

Also available in: Unified diff