Newer
Older
(** Time-stamp: <modified the 29/08/2008 (at 09:34) by Erwan Jahier> *)
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
let (get_predef : Ident.idref -> Predef.op option) =
fun idref ->
let get_op () =
try Some (Predef.string_to_op (Ident.to_string (Ident.name_of_idref idref)))
with Not_found -> None
in
match Ident.pack_of_idref idref with
| None -> get_op () (* The Lustre package is used by default *)
| Some p -> if (Ident.pack_name_to_string p) = "Lustre" then get_op () else None
open SyntaxTree
open SyntaxTreeCore
open Lxm
let flag f x_flg = Lxm.flagit (f x_flg.it) x_flg.src
let fopt f = function None -> None | Some x -> Some (f x)
(* just a tedious recursive traversal of the syntax tree, replacing idref
that match predef op with the Predef constructor *)
(* exported *)
let rec (recognize_predef_op : SyntaxTree.t -> SyntaxTree.t) = function
| PRPackBody(sl,pb) -> PRPackBody(sl, r_packbody pb)
| PRPack_or_models(sl,pml) -> PRPack_or_models(sl,List.map r_pack_or_model pml)
and r_pack_or_model = function
| NSPack(pi) -> NSPack(flag r_pack_info pi)
| NSModel(mi) -> NSModel(flag r_model_info mi)
and r_pack_info pi = { pi with pa_def = r_pack_def pi.pa_def }
and r_model_info mi =
{ mi with
mo_needs = List.map (flag r_static_param) mi.mo_needs;
mo_provides = r_item_info_flg_list mi.mo_provides;
mo_body = r_packbody mi.mo_body;
}
and r_pack_def = function
| PackGiven(pg) -> PackGiven(r_pack_given pg)
| PackInstance(pi) -> PackInstance(r_pack_instance pi)
and r_pack_given pg = {
pg with
pg_provides = r_item_info_flg_list pg.pg_provides;
pg_body = r_packbody pg.pg_body;
}
and r_pack_instance pi = { pi with pi_args = List.map (flag r_static_arg) pi.pi_args }
and r_static_param sp = sp
and r_static_arg = function
| StaticArgIdent(idref) -> (
match get_predef idref with
| None -> StaticArgIdent idref
| Some predef -> StaticArgNode (Predef_n (predef,[]))
)
| StaticArgConst(ve) -> StaticArgConst(r_val_exp ve)
| StaticArgType(te) -> StaticArgType(te)
| StaticArgNode(by_pos_op) -> StaticArgNode(r_by_pos_op by_pos_op)
and r_by_pos_op = function
| Predef_n(op,args) -> Predef_n(op,args) (* assert false *)
| CALL_n { src=lxm;it=(idref,sargs) } -> (
match get_predef idref with
| None -> CALL_n { src=lxm;it= r_node_exp (idref,sargs) }
| Some op -> Predef_n (op, List.map (flag r_static_arg) sargs)
)
| IDENT_n(idref) -> (
match get_predef idref with
| None -> IDENT_n(idref)
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
)
| ARRAY_ACCES_n(val_exp) -> ARRAY_ACCES_n(r_val_exp val_exp)
| ARRAY_SLICE_n(slice_info) -> ARRAY_SLICE_n(r_slice_info slice_info)
| x -> x
and r_node_exp (idref, sargs) =
(idref, List.map (flag r_static_arg) sargs)
and r_slice_info si = {
si_first = r_val_exp si.si_first;
si_last = r_val_exp si.si_last;
si_step = fopt r_val_exp si.si_step;
}
and r_val_exp = function
| CallByPos (by_pos_op, Oper vel) ->
CallByPos(flag r_by_pos_op by_pos_op, Oper (List.map r_val_exp vel))
| CallByName(by_name_op, args) ->
CallByName(by_name_op, List.map (fun (id, ve) -> id, r_val_exp ve) args)
and r_item_info_flg_list = function
| None -> None
| Some iil -> Some (List.map (flag r_item_info) iil)
and r_item_info = function
| ConstInfo ci -> ConstInfo(r_const_info ci)
| TypeInfo ti -> TypeInfo (r_type_info ti)
| NodeInfo ni -> NodeInfo (r_node_info ni)
and r_const_info = function
| ExternalConst(id,te,ve_opt) -> ExternalConst(id,te, fopt r_val_exp ve_opt)
| EnumConst(id,te) -> EnumConst(id,te)
| DefinedConst(id,te,ve) -> DefinedConst(id,te, r_val_exp ve)
and r_type_info = function
| ExternalType(id) -> ExternalType(id)
| AliasedType(id,te) -> AliasedType(id,te)
| EnumType(id,te) -> EnumType(id,te)
| StructType(sti) -> StructType(r_struct_type_info sti)
| ArrayType(id,te,ve) -> ArrayType(id,te, r_val_exp ve)
and r_node_info ni = {
ni with
static_params = List.map (flag r_static_param) ni.static_params;
def = r_node_def ni.def;
}
and r_struct_type_info sti =
Hashtbl.iter
(fun id fi -> Hashtbl.replace sti.st_ftable id (flag r_field_info fi))
sti.st_ftable;
sti
and r_field_info fi = { fi with fd_value = fopt r_val_exp fi.fd_value }
and r_node_def = function
| Extern -> Extern
| Abstract -> Abstract
| Body(node_body) -> Body(r_node_body node_body)
| Alias(by_pos_op) -> Alias(flag r_by_pos_op by_pos_op)
and r_packbody pb =
Hashtbl.iter
(fun id i -> Hashtbl.replace pb.pk_const_table id (flag r_const_info i))
pb.pk_const_table;
Hashtbl.iter
(fun id i -> Hashtbl.replace pb.pk_type_table id (flag r_type_info i))
pb.pk_type_table;
Hashtbl.iter
(fun id i -> Hashtbl.replace pb.pk_node_table id (flag r_node_info i))
pb.pk_node_table;
pb
and r_node_body nb = {
asserts = List.map (flag r_val_exp) nb.asserts;
eqs = List.map (flag r_eq_info) nb.eqs;
}
and r_eq_info (lpl,ve) = (List.map r_left_part lpl, r_val_exp ve)
and r_left_part = function
| LeftVar(id) -> LeftVar(id)
| LeftField(lp,id) -> LeftField(r_left_part lp,id)
| LeftArray(lp,ve) -> LeftArray(r_left_part lp, flag r_val_exp ve)
| LeftSlice(lp,si) -> LeftSlice(r_left_part lp, flag r_slice_info si)