lustrec / src / pathConditions.ml @ 66359a5e
History  View  Annotate  Download (10.5 KB)
1 
open LustreSpec 

2 
open Corelang 
3 
open Log 
4 
open Format 
5  
6 
module IdSet = Set.Make (struct type t = expr * int let compare = compare end) 
7  
8 
let inout_vars = ref [] 
9  
10 
(* This was used to add inout variables in the final signature. May have to be 
11 
reactivated later *) 
12 

13 
(* let print_tautology_var fmt v = *) 
14 
(* match (Types.repr v.var_type).Types.tdesc with *) 
15 
(*  Types.Tbool > Format.fprintf fmt "(%s or not %s)" v.var_id v.var_id *) 
16 
(*  Types.Tint > Format.fprintf fmt "(%s > 0 or %s <= 0)" v.var_id v.var_id *) 
17 
(*  Types.Treal > Format.fprintf fmt "(%s > 0 or %s <= 0)" v.var_id v.var_id *) 
18 
(*  _ > Format.fprintf fmt "(true)" *) 
19  
20 
(* let print_path arg = match !inout_vars with *) 
21 
(*  [] > Format.printf "%t@." arg *) 
22 
(*  l > Format.printf "%t and %a@." arg (Utils.fprintf_list ~sep:" and " (fun fmt elem > print_tautology_var fmt elem)) l *) 
23  
24 
let rel_op = ["="; "!="; "<"; "<="; ">" ; ">=" ] 
25  
26 
(* Used when we were printing the expression directly. Now we are constructing 
27 
them as regular expressions. 
28  
29 
let rec print_pre fmt nb_pre = if nb_pre <= 0 then () else ( Format.fprintf 
30 
fmt "pre "; print_pre fmt (nb_pre1) ) 
31 
*) 
32 

33 
let rec mk_pre n e = 
34 
if n <= 0 then 
35 
e 
36 
else 
37 
mkexpr e.expr_loc (Expr_pre e) 
38 

39 
(* 
40 
let combine2 f sub1 sub2 = 
41 
let elem_e1 = List.fold_right IdSet.add (List.map fst sub1) IdSet.empty in 
42 
let elem_e2 = List.fold_right IdSet.add (List.map fst sub2) IdSet.empty in 
43 
let common = IdSet.inter elem_e1 elem_e2 in 
44 
let sub1_filtered = List.filter (fun (v, _) > not (IdSet.mem v common)) sub1 in 
45 
let sub2_filtered = List.filter (fun (v, _) > not (IdSet.mem v common)) sub2 in 
46 
(List.map (fun (v, negv) > (v, f negv e2)) sub1_filtered) @ 
47 
(List.map (fun (v, negv) > (v, f e1 negv)) sub2_filtered) @ 
48 
(List.map (fun v > (v, {expr with expr_desc = Expr_arrow(List.assoc v sub1, List.assoc v sub2)}) (IdSet.elements common)) ) 
49 
*) 
50  
51 
let rec select (v: expr * int) (active: bool list) (modified: ((expr * int) * expr) list list) (orig: expr list) = 
52 
match active, modified, orig with 
53 
 true::active_tl, e::modified_tl, _::orig_tl > (List.assoc v e)::(select v active_tl modified_tl orig_tl) 
54 
 false::active_tl, _::modified_tl, e::orig_tl > e::(select v active_tl modified_tl orig_tl) 
55 
 [], [], [] > [] 
56 
 _ > assert false 
57 

58 
let combine (f: expr list > expr ) subs orig : ((expr * int) * expr) list = 
59 
let elems = List.map (fun sub_i > List.fold_right IdSet.add (List.map fst sub_i) IdSet.empty) subs in 
60 
let all = List.fold_right IdSet.union elems IdSet.empty in 
61 
List.map (fun v > 
62 
let active_subs = List.map (IdSet.mem v) elems in 
63 
v, f (select v active_subs subs orig) 
64 
) (IdSet.elements all) 
65  
66  
67 
(* In a previous version, the printer was introducing fake description, ie 
68 
tautologies, over inout variables to make sure they were not suppresed by 
69 
some other algorithms *) 
70  
71 
(* Takes the variable on which these coverage criteria will apply, as well as 
72 
the expression and its negated version. Returns the expr and the variable 
73 
expression, as well as the two new boolean expressions descibing the two 
74 
associated modes. *) 
75 
let mcdc_var vi_as_expr expr expr_neg_vi = 
76 
let loc = expr.expr_loc in 
77 
let changed_expr = mkpredef_call loc "!=" [expr; expr_neg_vi] in 
78 
let not_vi_as_expr = mkpredef_call loc "not" [vi_as_expr] in 
79 
let expr1 = mkpredef_call loc "&&" [vi_as_expr; changed_expr] in 
80 
let expr2 = mkpredef_call loc "&&" [not_vi_as_expr; changed_expr] in 
81 
((expr,vi_as_expr),[expr1;expr2]) 
82  
83 
(* Format.printf "%a@." Printers.pp_expr expr1; *) 
84 
(* print_path (fun fmt > Format.fprintf fmt "%a and (%a != %a)" *) 
85 
(* Printers.pp_expr vi_as_expr *) 
86 
(* Printers.pp_expr expr (\*v*\) *) 
87 
(* Printers.pp_expr expr_neg_vi); *) 
88 
(* Format.printf "%a@." Printers.pp_expr expr2; *) 
89 
(* print_path (fun fmt > Format.fprintf fmt "(not %a) and (%a != %a)" *) 
90 
(* Printers.pp_expr vi_as_expr *) 
91 
(* Printers.pp_expr expr (\*v*\) *) 
92 
(* Printers.pp_expr expr_neg_vi) *) 
93 

94 
let rec compute_neg_expr cpt_pre (expr: LustreSpec.expr) = 
95 
let neg_list l = 
96 
List.fold_right (fun e (vl,el) > let vl', e' = compute_neg_expr cpt_pre e in (vl'@vl), e'::el) l ([], []) 
97 
in 
98 
match expr.expr_desc with 
99 
 Expr_tuple l > 
100 
let vl, neg = neg_list l in 
101 
vl, combine (fun l' > {expr with expr_desc = Expr_tuple l'}) neg l 
102 

103 
 Expr_ite (i,t,e) when (Types.is_bool_type t.expr_type) > ( 
104 
let list = [i; t; e] in 
105 
let vl, neg = neg_list list in 
106 
vl, combine (fun l > 
107 
match l with 
108 
 [i'; t'; e'] > {expr with expr_desc = Expr_ite(i', t', e')} 
109 
 _ > assert false 
110 
) neg list 
111 
) 
112 
 Expr_ite (i,t,e) > ( (* We return the guard as a new guard *) 
113 
let vl = gen_mcdc_cond_guard i in 
114 
let list = [i; t; e] in 
115 
let vl', neg = neg_list list in 
116 
vl@vl', combine (fun l > 
117 
match l with 
118 
 [i'; t'; e'] > {expr with expr_desc = Expr_ite(i', t', e')} 
119 
 _ > assert false 
120 
) neg list 
121 
) 
122 
 Expr_arrow (e1, e2) > 
123 
let vl1, e1' = compute_neg_expr cpt_pre e1 in 
124 
let vl2, e2' = compute_neg_expr cpt_pre e2 in 
125 
vl1@vl2, combine (fun l > match l with 
126 
 [x;y] > { expr with expr_desc = Expr_arrow (x, y) } 
127 
 _ > assert false 
128 
) [e1'; e2'] [e1; e2] 
129  
130 
 Expr_pre e > 
131 
let vl, e' = compute_neg_expr (cpt_pre+1) e in 
132 
vl, List.map 
133 
(fun (v, negv) > (v, { expr with expr_desc = Expr_pre negv } )) e' 
134  
135 
 Expr_appl (op_name, args, r) when List.mem op_name rel_op > 
136 
[], [(expr, cpt_pre), mkpredef_call expr.expr_loc "not" [expr]] 
137  
138 
 Expr_appl (op_name, args, r) > 
139 
let vl, args' = compute_neg_expr cpt_pre args in 
140 
vl, List.map 
141 
(fun (v, negv) > (v, { expr with expr_desc = Expr_appl (op_name, negv, r) } )) 
142 
args' 
143  
144 
 Expr_ident _ when (Types.is_bool_type expr.expr_type) > 
145 
[], [(expr, cpt_pre), mkpredef_call expr.expr_loc "not" [expr]] 
146 
 _ > [] (* empty vars *) , [] 
147 
and gen_mcdc_cond_var v expr = 
148 
report ~level:1 (fun fmt > 
149 
Format.fprintf fmt ".. Generating MC/DC cond for boolean flow %s and expression %a@." 
150 
v 
151 
Printers.pp_expr expr); 
152 
let vl, leafs_n_neg_expr = compute_neg_expr 0 expr in 
153 
if List.length leafs_n_neg_expr > 1 then ( 
154 
List.fold_left (fun accu ((vi, nb_pre), expr_neg_vi) > 
155 
(mcdc_var (mk_pre nb_pre vi) expr expr_neg_vi)::accu 
156 
) vl leafs_n_neg_expr 
157 
) 
158 
else vl 
159  
160 
and gen_mcdc_cond_guard expr = 
161 
report ~level:1 (fun fmt > 
162 
Format.fprintf fmt".. Generating MC/DC cond for guard %a@." 
163 
Printers.pp_expr expr); 
164 
let vl, leafs_n_neg_expr = compute_neg_expr 0 expr in 
165 
if List.length leafs_n_neg_expr > 1 then ( 
166 
List.fold_left (fun accu ((vi, nb_pre), expr_neg_vi) > 
167 
(mcdc_var (mk_pre nb_pre vi) expr expr_neg_vi)::accu 
168 
) vl leafs_n_neg_expr) 
169 
else 
170 
vl 
171 

172  
173 
let rec mcdc_expr cpt_pre expr = 
174 
match expr.expr_desc with 
175 
 Expr_tuple l > 
176 
let vl = 
177 
List.fold_right (fun e accu_v > 
178 
let vl = mcdc_expr cpt_pre e in 
179 
(vl@accu_v)) 
180 
l 
181 
[] 
182 
in 
183 
vl 
184 
 Expr_ite (i,t,e) > 
185 
let vl_i = gen_mcdc_cond_guard i in 
186 
let vl_t = mcdc_expr cpt_pre t in 
187 
let vl_e = mcdc_expr cpt_pre e in 
188 
vl_i@vl_t@vl_e 
189 
 Expr_arrow (e1, e2) > 
190 
let vl1 = mcdc_expr cpt_pre e1 in 
191 
let vl2 = mcdc_expr cpt_pre e2 in 
192 
vl1@vl2 
193 
 Expr_pre e > 
194 
let vl = mcdc_expr (cpt_pre+1) e in 
195 
vl 
196 
 Expr_appl (f, args, r) > 
197 
let vl = mcdc_expr cpt_pre args in 
198 
vl 
199 
 _ > [] 
200  
201 
let mcdc_var_def v expr = 
202 
if Types.is_bool_type expr.expr_type then 
203 
let vl = gen_mcdc_cond_var v expr in 
204 
vl 
205 
else 
206 
let vl = mcdc_expr 0 expr in 
207 
vl 
208 

209 
let mcdc_node_eq eq = 
210 
let vl = 
211 
match eq.eq_lhs, Types.is_bool_type eq.eq_rhs.expr_type, (Types.repr eq.eq_rhs.expr_type).Types.tdesc, eq.eq_rhs.expr_desc with 
212 
 [lhs], true, _, _ > gen_mcdc_cond_var lhs eq.eq_rhs 
213 
 _::_, false, Types.Ttuple tl, Expr_tuple rhs > 
214 
(* We iterate trough pairs, but accumulate variables aside. The resulting 
215 
expression shall remain a tuple defintion *) 
216 
let vl = List.fold_right2 (fun lhs rhs accu > 
217 
let v = mcdc_var_def lhs rhs in 
218 
(* we don't care about the expression it. We focus on the coverage 
219 
expressions in v *) 
220 
v@accu 
221 
) eq.eq_lhs rhs [] 
222 
in 
223 
vl 
224 
 _ > mcdc_expr 0 eq.eq_rhs 
225 
in 
226 
vl 
227  
228 
let mcdc_node_stmt stmt = 
229 
match stmt with 
230 
 Eq eq > let vl = mcdc_node_eq eq in vl 
231 
 Aut aut > assert false 
232  
233 
let mcdc_top_decl td = 
234 
match td.top_decl_desc with 
235 
 Node nd > 
236 
let new_coverage_exprs = 
237 
List.fold_right ( 
238 
fun s accu_v > 
239 
let vl' = mcdc_node_stmt s in 
240 
vl'@accu_v 
241 
) nd.node_stmts [] 
242 
in 
243 
(* We add coverage vars as boolean internal flows. TODO *) 
244 
let fresh_cov_defs = List.flatten (List.map snd new_coverage_exprs) in 
245 
let nb_total = List.length fresh_cov_defs in 
246 
let fresh_cov_vars = List.mapi (fun i cov_expr > 
247 
let loc = cov_expr.expr_loc in 
248 
Format.fprintf Format.str_formatter "__cov_%i_%i" i nb_total; 
249 
let cov_id = Format.flush_str_formatter () in 
250 
let cov_var = mkvar_decl loc 
251 
(cov_id, mktyp loc Tydec_bool, mkclock loc Ckdec_any, false, None, None) in 
252 
let cov_def = Eq (mkeq loc ([cov_id], cov_expr)) in 
253 
cov_var, cov_def, cov_expr 
254 
) fresh_cov_defs 
255 
in 
256 
let fresh_vars, fresh_eqs = 
257 
List.fold_right 
258 
(fun (v,eq,_) (accuv, accueq)> v::accuv, eq::accueq ) 
259 
fresh_cov_vars 
260 
([], []) 
261 
in 
262 
let fresh_annots = (* We produce two sets of annotations: PROPERTY ones for 
263 
kind2, and regular ones to keep track of the nature 
264 
of the annotations. *) 
265 
List.map 
266 
(fun v > let ee = expr_to_eexpr (expr_of_vdecl v) in 
267 
{annots = [["PROPERTY"], ee; 
268 
["coverage";"mcdc"], ee 
269 
]; 
270 
annot_loc = v.var_loc}) 
271 
fresh_vars 
272 
in 
273 
Format.printf "%i coverage criteria generated for node %s@ " nb_total nd.node_id; 
274 
(* And add them as annotations %PROPERTY: var TODO *) 
275 
{td with top_decl_desc = Node {nd with 
276 
node_locals = nd.node_locals@fresh_vars; 
277 
node_stmts = nd.node_stmts@fresh_eqs; 
278 
node_annot = nd.node_annot@fresh_annots 
279 
}} 
280 
 _ > td 
281  
282  
283 
let mcdc prog = 
284 
(* If main node is provided add silly constraints to show in/out variables in the path condition *) 
285 
if !Options.main_node <> "" then ( 
286 
inout_vars := 
287 
let top = List.find 
288 
(fun td > 
289 
match td.top_decl_desc with 
290 
 Node nd when nd.node_id = !Options.main_node > true 
291 
 _ > false) 
292 
prog 
293 
in 
294 
match top.top_decl_desc with 
295 
 Node nd > nd.node_inputs @ nd.node_outputs 
296 
 _ > assert false); 
297 
List.map mcdc_top_decl prog 
298  
299  
300 

301 
(* Local Variables: *) 
302 
(* compilecommand:"make C .." *) 
303 
(* End: *) 
304  
305 
