Revision 6aeb3388
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