| 1 | % (c) 2014-2022 Lehrstuhl fuer Softwaretechnik und Programmiersprachen, | |
| 2 | % Heinrich Heine Universitaet Duesseldorf | |
| 3 | % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html) | |
| 4 | ||
| 5 | :- module(mcdc_coverage,[get_mcdc_coverage_criterion/4, mcdc_true/4, mcdc_false/4, | |
| 6 | tcltk_compute_mcdc_operation_coverage/2, tcltk_compute_mcdc_operation_coverage/1, | |
| 7 | tcltk_compute_mcdc_invariant_coverage/2, tcltk_compute_mcdc_invariant_coverage/1, | |
| 8 | tcltk_get_invariant_coverage/1, | |
| 9 | construct_mcdc_operation_criteria/1, | |
| 10 | check_criteria/2]). | |
| 11 | ||
| 12 | :- use_module(probsrc(module_information),[module_info/2]). | |
| 13 | :- module_info(group,test_generation). | |
| 14 | :- module_info(description,'A module to construct MC/DC coverage criterion predicates and check them in the state space'). | |
| 15 | ||
| 16 | ||
| 17 | :- use_module(library(lists)). | |
| 18 | :- use_module(probsrc(b_operation_guards),[get_operation_enabling_condition/7]). | |
| 19 | %:- use_module(b_ast_cleanup, [clean_up/3]). | |
| 20 | :- use_module(probsrc(b_interpreter_components),[construct_optimized_exists/3]). | |
| 21 | :- use_module(probsrc(bsyntaxtree)). | |
| 22 | :- use_module(probsrc(error_manager)). | |
| 23 | :- use_module(probsrc(tools_strings),[ajoin/2]). | |
| 24 | :- use_module(probsrc(b_interpreter),[b_test_boolean_expression_cs/5]). | |
| 25 | :- use_module(probsrc(specfile),[state_corresponds_to_initialised_b_machine/2]). | |
| 26 | ||
| 27 | % not yet finished: | |
| 28 | /* | |
| 29 | vacuous_guard_component(OpName,Result) :- | |
| 30 | get_mcdc_coverage_criterion(1,OpName,RequiredCoverageCriterion,Tree), | |
| 31 | translate:translate_bexpression_with_limit(GuardPart,GuardTS), | |
| 32 | format('Checking vor vacuity: ~w -> ~w : ~w~n',[OpName,CoverageMsg,GuardTS]), | |
| 33 | %translate:print_bexpr(Neg),nl, | |
| 34 | (test_boolean_expression_in_node(ResID,RequiredCoverageCriterion) | |
| 35 | -> print(criterion_satisfied_in(ResID)),nl,nl, | |
| 36 | fail | |
| 37 | ; print(' *** VACUOUS GUARD COMPONENT *** '),nl,nl, | |
| 38 | ajoin([OpName,' : ',CoverageMsg,' : ',GuardTS],Result) | |
| 39 | ). | |
| 40 | */ | |
| 41 | :- use_module(probsrc(state_space),[visited_expression/2]). | |
| 42 | test_boolean_expression_in_node(ResID,BoolExpr) :- | |
| 43 | visited_expression(ResID,CurState), | |
| 44 | state_corresponds_to_initialised_b_machine(CurState,CurBState), | |
| 45 | b_test_boolean_expression_cs(BoolExpr,[],CurBState,'MCDC coverage',ResID). | |
| 46 | ||
| 47 | ||
| 48 | %:- use_module(probsrc(mcdc_coverage)), construct_mcdc_operation_criteria(1), check_criteria(Nr,Result). | |
| 49 | ||
| 50 | % store list of criteria | |
| 51 | :- dynamic criteria/4, nr_of_criteria/1. | |
| 52 | nr_of_criteria(0). | |
| 53 | ||
| 54 | reset_criteria :- retractall(criteria(_,_,_,_)), | |
| 55 | retractall(nr_of_criteria(_)), assertz(nr_of_criteria(0)). | |
| 56 | ||
| 57 | add_criteria(Op,Pred,InfoTree) :- | |
| 58 | retract(nr_of_criteria(Nr)), N1 is Nr+1, | |
| 59 | assertz(nr_of_criteria(N1)), | |
| 60 | assertz(criteria(N1,Op,Pred,InfoTree)). | |
| 61 | ||
| 62 | % generate MCDC criteria for a certain nesting level | |
| 63 | % level 0 -> only enabling/disabling, ... | |
| 64 | construct_mcdc_operation_criteria(Level) :- | |
| 65 | get_mcdc_coverage_criterion(Level,OpName,RequiredCoverageCriterionPred,Tree), | |
| 66 | add_criteria(OpName,RequiredCoverageCriterionPred,Tree), | |
| 67 | fail. | |
| 68 | construct_mcdc_operation_criteria(_) :- nr_of_criteria(Nr), format('Nr of MC/DC criteria: ~w~n',[Nr]). | |
| 69 | ||
| 70 | ||
| 71 | construct_mcdc_invariant_criteria(Level) :- | |
| 72 | get_mcdc_invariant_coverage_criterion(Level,InvName,RequiredCoverageCriterionPred,Tree), | |
| 73 | add_criteria(InvName,RequiredCoverageCriterionPred,Tree), | |
| 74 | fail. | |
| 75 | construct_mcdc_invariant_criteria(_) :- nr_of_criteria(Nr), format('Nr of MC/DC INV criteria: ~w~n',[Nr]). | |
| 76 | ||
| 77 | % check a given criteria | |
| 78 | check_criteria(Nr,Result) :- | |
| 79 | criteria(Nr,OpName,Pred,InfoTree), | |
| 80 | translate:translate_bexpression_with_limit(Pred,TS), | |
| 81 | format('~nChecking: ~w : ~w~n',[OpName,TS]), | |
| 82 | explain(InfoTree,0), | |
| 83 | %translate:print_bexpr(Neg),nl, | |
| 84 | (test_boolean_expression_in_node(ResID,Pred) | |
| 85 | -> print(criterion_satisfied_in(ResID)),nl,nl, | |
| 86 | Result = ResID | |
| 87 | ; Result = uncovered | |
| 88 | ). | |
| 89 | ||
| 90 | :- use_module(probsrc(preferences), [get_preference/2]). | |
| 91 | ||
| 92 | tcltk_compute_mcdc_invariant_coverage(Res) :- | |
| 93 | get_preference(mc_dc_default_level,Level), | |
| 94 | tcltk_compute_mcdc_invariant_coverage(Level,Res). | |
| 95 | tcltk_compute_mcdc_operation_coverage(Res) :- | |
| 96 | get_preference(mc_dc_default_level,Level), | |
| 97 | tcltk_compute_mcdc_operation_coverage(Level,Res). | |
| 98 | ||
| 99 | tcltk_compute_mcdc_invariant_coverage(Level,list([list(['Nr','Invariant','Path to Condition', 'Condition', 'Result', 'Source'])|Result])) :- | |
| 100 | reset_criteria, | |
| 101 | construct_mcdc_invariant_criteria(Level), | |
| 102 | findall(list([Nr,Operation,CriterionMsg,PredS,Result,Source]), | |
| 103 | get_individual_criteria(Nr,Operation,CriterionMsg,PredS,Result,Source), | |
| 104 | Result). | |
| 105 | tcltk_compute_mcdc_operation_coverage(Level,list([list(['Nr','Operation','Path to Condition', 'Condition', 'Result', 'Source'])|Result])) :- | |
| 106 | reset_criteria, | |
| 107 | construct_mcdc_operation_criteria(Level), | |
| 108 | findall(list([Nr,Operation,CriterionMsg,PredS,Result,Source]), | |
| 109 | get_individual_criteria(Nr,Operation,CriterionMsg,PredS,Result,Source), | |
| 110 | Result). | |
| 111 | ||
| 112 | get_individual_criteria(Nr,OpName,CriterionMsg,PredS,Result,Source) :- | |
| 113 | get_criteria_info(Nr,OpName,CriterionMsg,PredS,Source), | |
| 114 | enter_new_error_scope(ScopeID,mcdc_check_criteria(Nr)), | |
| 115 | check_criteria(Nr,Result), | |
| 116 | exit_error_scope(ScopeID,ErrOcc,mcdc_check_criteria(Nr)), | |
| 117 | (ErrOcc=true | |
| 118 | -> format('Error occured during MC/DC checking of criteria ~w (~w)~n ~w~n Result: ~w~n',[Nr,OpName,PredS,Result]) | |
| 119 | % TO DO: reset errors | |
| 120 | ; true). | |
| 121 | ||
| 122 | :- use_module(probsrc(translate),[translate_bexpression_with_limit/3]). | |
| 123 | get_criteria_info(Nr,OpName,CritMsg,PredS,Source) :- | |
| 124 | criteria(Nr,OpName,_Pred,InfoTree), | |
| 125 | get_criteria_tree_info(InfoTree,CritMsg,Pred,Source), | |
| 126 | translate_bexpression_with_limit(Pred,40,PredS). | |
| 127 | ||
| 128 | get_mcdc_coverage_criterion(Level,OpName,RequiredCoverageCriterionPred,Tree) :- | |
| 129 | get_operation_enabling_condition(OpName,Parameters,EnablingCondition,_BecomesSuchVars,_Precise,false,true), | |
| 130 | % TO DO: partition; avoid lifting becomes_such_that conditions | |
| 131 | % (in EventB the feasibility PO will ensure that Guard => BecomeSuchThat is ok) | |
| 132 | dif(OpName, '$initialise_machine'), | |
| 133 | (mcdc_true(Level,EnablingCondition,TargetPred,Tree) ; | |
| 134 | mcdc_false(Level,EnablingCondition,TargetPred,Tree) ), | |
| 135 | construct_optimized_exists(Parameters,TargetPred,RequiredCoverageCriterionPred), | |
| 136 | translate:print_bexpr(RequiredCoverageCriterionPred),nl. | |
| 137 | ||
| 138 | :- use_module(probsrc(bmachine),[b_get_invariant_from_machine/1]). | |
| 139 | get_mcdc_invariant_coverage_criterion(Level,InvName,TargetPred,Tree) :- | |
| 140 | b_get_invariant_from_machine(InvPred), | |
| 141 | mcdc_true(Level,InvPred,TargetPred,Tree), % we do not expect an INVARIANT to be false: only call mcdc_true | |
| 142 | get_invariant_name(Tree,InvName). | |
| 143 | ||
| 144 | get_invariant_name(conjunct_true(PosNr,SinglePred,_InnerTree),Name) :- !, | |
| 145 | (bsyntaxtree:get_texpr_label(SinglePred,Name) -> true | |
| 146 | ; ajoin(['INV',PosNr],Name)). | |
| 147 | get_invariant_name(_,'INV'). | |
| 148 | ||
| 149 | %:- use_module(probsrc(mcdc_coverage)), get_mcdc_coverage_criterion(OpName,RequiredCoverageCriterionPred,_,_). | |
| 150 | ||
| 151 | select_pred(List, Rest1, Pred, Rest2, PosNr) :- | |
| 152 | append(Rest1,[Pred|Rest2],List), length(Rest1,L1), PosNr is L1+1. | |
| 153 | ||
| 154 | % mcdc_true(Level, PredicateToCover, TargetPredicate, TreeOfMDCCriterion) | |
| 155 | mcdc_true(0,Predicate,TargetPred, ResTree) :- !, ResTree=true(TargetPred), TargetPred=Predicate. | |
| 156 | mcdc_true(Level,Predicate,TargetPred, Res) :- Level>1, | |
| 157 | is_a_conjunct(Predicate,_,_), | |
| 158 | !, L1 is Level-1, | |
| 159 | Res = conjunct_true(PosNr,SinglePred,InnerTree), | |
| 160 | % select every conjunct and check that we can make it true (with the rest also true) and cover its inner MCDC criteria | |
| 161 | conjunction_to_list(Predicate,List), | |
| 162 | select_pred(List, Rest1, SinglePred, Rest2, PosNr), | |
| 163 | mcdc_true(L1,SinglePred, InnerTargetPred, InnerTree), % compute inner MCDC criteria for selected conjunct SinglePred | |
| 164 | append(Rest1,[InnerTargetPred|Rest2],TargetList), | |
| 165 | conjunct_predicates(TargetList,TargetPred). | |
| 166 | mcdc_true(Level,Predicate,TargetPred, Res) :- | |
| 167 | is_a_disjunct(Predicate,_,_), | |
| 168 | !, L1 is Level-1, | |
| 169 | Res = disjunct_true(PosNr,SinglePred,InnerTree), | |
| 170 | % check that every disjunct can be set individually to true: | |
| 171 | % A1 or ... Ai or ... Ak ----------> not(A1) & not(A2) ... Ai & ... not(Ak) | |
| 172 | disjunction_to_list(Predicate,DisjList), | |
| 173 | select_pred(DisjList, Rest1, SinglePred, Rest2, PosNr), | |
| 174 | mcdc_true(L1,SinglePred, InnerTargetPred, InnerTree), | |
| 175 | maplist(create_negation,Rest1,NRest1), | |
| 176 | maplist(create_negation,Rest2,NRest2), | |
| 177 | append(NRest1,[InnerTargetPred|NRest2],TargetList), | |
| 178 | conjunct_predicates(TargetList,TargetPred). | |
| 179 | mcdc_true(Level,Predicate,TargetPred, Res) :- | |
| 180 | is_an_implication(Predicate,LHS,RHS), | |
| 181 | !, L1 is Level-1, | |
| 182 | Res = implication_true(Pos,Pred,InnerTree), | |
| 183 | ( mcdc_false(L1,LHS,InnerTargetPred,InnerTree), | |
| 184 | Pos = lhs_false, Pred = LHS, | |
| 185 | create_negation(RHS,NRHS), | |
| 186 | % check not(LHS) & not(RHS) -> relevant that LHS is false, otherwise implication false | |
| 187 | conjunct_predicates([InnerTargetPred,NRHS],TargetPred) | |
| 188 | ; | |
| 189 | mcdc_true(L1,RHS,InnerTargetPred,InnerTree), | |
| 190 | Pos = rhs_true, Pred = RHS, | |
| 191 | % check LHS & RHS -> relevant that RHS is true, otherwise implication false | |
| 192 | conjunct_predicates([LHS,InnerTargetPred],TargetPred) | |
| 193 | ). | |
| 194 | mcdc_true(Level,Predicate,TargetPred, Res) :- | |
| 195 | is_an_equivalence(Predicate,LHS,RHS), | |
| 196 | !, L1 is Level-1, | |
| 197 | Res = equivalence_true(Pos,Pred,InnerTree), | |
| 198 | ( /* focus on LHS */ % We try and create TRUE <=> TRUE; we could decide based upon structure of LHS/RHS | |
| 199 | mcdc_true(L1,LHS,InnerTargetPred,InnerTree), | |
| 200 | Pos = lhs_true, Pred = LHS, | |
| 201 | conjunct_predicates([InnerTargetPred,RHS],TargetPred) | |
| 202 | ;/* focus on RHS */ | |
| 203 | mcdc_false(L1,RHS,InnerTargetPred,InnerTree), % we could generate mcdc_true(L1,RHS) also | |
| 204 | Pos = rhs_false, Pred = RHS, | |
| 205 | create_negation(LHS,NLHS), | |
| 206 | conjunct_predicates([NLHS,InnerTargetPred],TargetPred) | |
| 207 | ). | |
| 208 | mcdc_true(Level,Predicate,TargetPred, Res) :- | |
| 209 | is_a_negation(Predicate,NPred), | |
| 210 | !, | |
| 211 | Res = negation(InnerTree), | |
| 212 | mcdc_false(Level,NPred,TargetPred, InnerTree). | |
| 213 | mcdc_true(_,Predicate,Predicate,true(Predicate)). | |
| 214 | % TO DO: add implication and equivalence and maybe quantifiers | |
| 215 | ||
| 216 | mcdc_false(0,Predicate,TargetPred,Res) :- !, Res = false(Predicate), | |
| 217 | create_negation(Predicate,TargetPred). | |
| 218 | mcdc_false(Level,Predicate,TargetPred, Res) :- | |
| 219 | is_a_conjunct(Predicate,_,_), | |
| 220 | !, L1 is Level-1, | |
| 221 | Res = conjunct_false(PosNr,SinglePred,InnerTree), | |
| 222 | % check that every conjunct can be set individually to false: | |
| 223 | % A1 & ... Ai & ... Ak ----------> A1 & A2 ... not(Ai) & ... Ak | |
| 224 | conjunction_to_list(Predicate,List), | |
| 225 | select_pred(List, Rest1, SinglePred, Rest2, PosNr), | |
| 226 | mcdc_false(L1,SinglePred, InnerTargetPred, InnerTree), | |
| 227 | append(Rest1,[InnerTargetPred|Rest2],NewConj), % TO DO: better treatment for well-definedness !? | |
| 228 | % if SinglePred is a WD-Guard for Rest2: do not require to analyse Rest2 ?! | |
| 229 | conjunct_predicates(NewConj,TargetPred). | |
| 230 | mcdc_false(Level,Predicate,TargetPred, Res) :- Level>1, | |
| 231 | is_a_disjunct(Predicate,_,_), | |
| 232 | !, L1 is Level-1, | |
| 233 | Res = disjunct_false(PosNr,SinglePred,InnerTree), | |
| 234 | % select every disjunct and check that we can make it false (with the rest also false) and cover its inner MCDC criteria | |
| 235 | disjunction_to_list(Predicate,List), | |
| 236 | select_pred(List, Rest1, SinglePred, Rest2, PosNr), | |
| 237 | maplist(create_negation,Rest1,NRest1), maplist(create_negation,Rest2,NRest2), % negate all other disjuncts | |
| 238 | mcdc_false(L1,SinglePred, InnerTargetPred, InnerTree), % compute inner MCDC criteria for selected conjunct SinglePred | |
| 239 | append(NRest1,[InnerTargetPred|NRest2],TargetList), | |
| 240 | conjunct_predicates(TargetList,TargetPred). | |
| 241 | mcdc_false(Level,Predicate,TargetPred, Res) :- Level>1, | |
| 242 | is_an_implication(Predicate,LHS,RHS), | |
| 243 | % check LHS & not(RHS) and generate MCDC criteria for LHS and RHS if Level>1 | |
| 244 | !, L1 is Level-1, | |
| 245 | Res = implication_false(Pos,Pred,InnerTree), | |
| 246 | ( mcdc_true(L1,LHS,InnerTargetPred,InnerTree), % TRUE <=> TRUE with focus on LHS | |
| 247 | Pos = lhs_true, Pred = LHS, | |
| 248 | create_negation(RHS,NRHS), | |
| 249 | conjunct_predicates([InnerTargetPred,NRHS],TargetPred) | |
| 250 | ; | |
| 251 | mcdc_false(L1,RHS,InnerTargetPred,InnerTree), % FALSE <=> FALSE with focus on RHS | |
| 252 | Pos = rhs_false, Pred = RHS, | |
| 253 | conjunct_predicates([LHS,InnerTargetPred],TargetPred) | |
| 254 | ). | |
| 255 | mcdc_false(Level,Predicate,TargetPred, Res) :- | |
| 256 | is_an_equivalence(Predicate,LHS,RHS), | |
| 257 | !, L1 is Level-1, | |
| 258 | Res = equivalence_false(Pos,Pred,InnerTree), | |
| 259 | ( /* focus on LHS */ % We create FALSE <=> TRUE and focus on LHS | |
| 260 | mcdc_false(L1,LHS,InnerTargetPred,InnerTree), | |
| 261 | Pos = lhs_false, Pred = LHS, | |
| 262 | conjunct_predicates([InnerTargetPred,RHS],TargetPred) | |
| 263 | ;/* focus on RHS */ | |
| 264 | mcdc_true(L1,RHS,InnerTargetPred,InnerTree), % we generate FALSE <=> TRUE and focus on RHS | |
| 265 | Pos = rhs_false, Pred = RHS, | |
| 266 | create_negation(LHS,NLHS), | |
| 267 | conjunct_predicates([NLHS,InnerTargetPred],TargetPred) | |
| 268 | ). | |
| 269 | mcdc_false(Level,Predicate,TargetPred, Res) :- | |
| 270 | is_a_negation(Predicate,NPred), | |
| 271 | !, | |
| 272 | Res = negation(InnerTree), | |
| 273 | mcdc_true(Level,NPred,TargetPred, InnerTree). | |
| 274 | mcdc_false(_,Predicate,TargetPred,Res) :- !, | |
| 275 | Res = false(Predicate), | |
| 276 | create_negation(Predicate,TargetPred). | |
| 277 | ||
| 278 | :- use_module(probsrc(translate),[print_bexpr/1]). | |
| 279 | explain(true(Pred),L) :- !, indent(L), print('TRUE: '),print_bexpr(Pred),nl. | |
| 280 | explain(false(Pred),L) :- !, indent(L), print('FALSE: '),print_bexpr(Pred),nl. | |
| 281 | explain(conjunct_true(PosNr,Pred,InnerTree),L) :- !, | |
| 282 | indent(L), format('Conjunct ~w TRUE: ',[PosNr]), print_bexpr(Pred), | |
| 283 | nl, | |
| 284 | L1 is L+1, explain(InnerTree,L1). | |
| 285 | explain(conjunct_false(PosNr,Pred,InnerTree),L) :- !, | |
| 286 | get_position_info(Pred,PI), | |
| 287 | indent(L), format('Conjunct ~w~w individually FALSE: ',[PosNr,PI]), %print_bexpr(Pred), | |
| 288 | nl, | |
| 289 | L1 is L+1, explain(InnerTree,L1). | |
| 290 | explain(disjunct_true(PosNr,Pred,InnerTree),L) :- !, | |
| 291 | get_position_info(Pred,PI), | |
| 292 | indent(L), format('Disjunct ~w~w individually TRUE: ',[PosNr,PI]), %print_bexpr(Pred), | |
| 293 | nl, | |
| 294 | L1 is L+1, explain(InnerTree,L1). | |
| 295 | explain(disjunct_false(PosNr,Pred,InnerTree),L) :- !, | |
| 296 | get_position_info(Pred,PI), | |
| 297 | indent(L), format('Disjunct ~w~w FALSE: ',[PosNr,PI]), print_bexpr(Pred), | |
| 298 | nl, | |
| 299 | L1 is L+1, explain(InnerTree,L1). | |
| 300 | explain(implication_true(lhs_false,Pred,InnerTree),L) :- !, | |
| 301 | get_position_info(Pred,PI), | |
| 302 | indent(L), format('Implication LHS~w individually FALSE: ',[PI]), %print_bexpr(Pred), | |
| 303 | nl, | |
| 304 | L1 is L+1, explain(InnerTree,L1). | |
| 305 | explain(implication_true(rhs_true,Pred,InnerTree),L) :- !, | |
| 306 | get_position_info(Pred,PI), | |
| 307 | indent(L), format('Implication RHS~w individually TRUE: ',[PI]), %print_bexpr(Pred), | |
| 308 | nl, | |
| 309 | L1 is L+1, explain(InnerTree,L1). | |
| 310 | explain(equivalence_true(rhs_false,Pred,InnerTree),L) :- !, | |
| 311 | get_position_info(Pred,PI), | |
| 312 | indent(L), format('Equivalence RHS~w FALSE: ',[PI]), %print_bexpr(Pred), | |
| 313 | nl, | |
| 314 | L1 is L+1, explain(InnerTree,L1). | |
| 315 | explain(equivalence_true(lhs_true,Pred,InnerTree),L) :- !, | |
| 316 | get_position_info(Pred,PI), | |
| 317 | indent(L), format('Equivalence LHS~w TRUE: ',[PI]), %print_bexpr(Pred), | |
| 318 | nl, | |
| 319 | L1 is L+1, explain(InnerTree,L1). | |
| 320 | explain(equivalence_false(Pos,Pred,InnerTree),L) :- !, | |
| 321 | get_position_info(Pred,PI), | |
| 322 | indent(L), format('Equivalence ~w ~w: ',[Pos,PI]), %print_bexpr(Pred), | |
| 323 | nl, | |
| 324 | L1 is L+1, explain(InnerTree,L1). | |
| 325 | explain(negation(InnerTree),L) :- !, | |
| 326 | indent(L), print('NEGATION'), | |
| 327 | nl, | |
| 328 | L1 is L+1, explain(InnerTree,L1). | |
| 329 | explain(implication_false(lhs_true,Pred,InnerTree),L) :- !, | |
| 330 | get_position_info(Pred,PI), | |
| 331 | indent(L), format('Implication F with LHS~w TRUE: ',[PI]), %print_bexpr(Pred), | |
| 332 | nl, | |
| 333 | L1 is L+1, explain(InnerTree,L1). | |
| 334 | explain(implication_false(rhs_false,Pred,InnerTree),L) :- !, | |
| 335 | get_position_info(Pred,PI), | |
| 336 | indent(L), format('Implication F with RHS~w FALSE: ',[PI]), %print_bexpr(Pred), | |
| 337 | nl, | |
| 338 | L1 is L+1, explain(InnerTree,L1). | |
| 339 | explain(Term,L) :- indent(L), print(Term),nl, | |
| 340 | add_internal_error('Uncovered Info Tree: ', explain(Term,L)). | |
| 341 | % TO DO: generate a string that can be used e.g. by Tcl/Tk to put into a dialog box ? | |
| 342 | ||
| 343 | indent(0) :- print('+--> '). | |
| 344 | indent(N) :- N>0, print('+--'), N1 is N-1, indent(N1). | |
| 345 | ||
| 346 | % column must be called 'Source' | |
| 347 | get_position_info(Expr,PosStr) :- | |
| 348 | bsyntaxtree:get_texpr_labels(Expr,Names),!, | |
| 349 | ajoin([' @', Names],PosStr). | |
| 350 | get_position_info(Expr,PosStr) :- !,get_tk_table_position_info(Expr,PosStr). | |
| 351 | ||
| 352 | use_position_info_if_not_defined('',Expr,PosStr) :- !, get_position_info(Expr,PosStr). | |
| 353 | use_position_info_if_not_defined(PosStr,_,PosStr). | |
| 354 | ||
| 355 | ||
| 356 | % extract information from criteria tree term | |
| 357 | get_criteria_tree_info(true(Pred),'TRUE',Pred,PosInfo) :- !, get_position_info(Pred,PosInfo). | |
| 358 | get_criteria_tree_info(false(Pred),'FALSE',Pred,PosInfo) :- !, get_position_info(Pred,PosInfo). | |
| 359 | get_criteria_tree_info(conjunct_true(PosNr,CPred,InnerTree),Msg,Pred,Source) :- !, | |
| 360 | get_criteria_tree_info(InnerTree,IMsg,Pred,ISource), | |
| 361 | use_position_info_if_not_defined(ISource,CPred,Source), | |
| 362 | ajoin(['&(',PosNr,')T; ',IMsg],Msg). | |
| 363 | get_criteria_tree_info(conjunct_false(PosNr,CPred,InnerTree),Msg,Pred,Source) :- !, | |
| 364 | get_criteria_tree_info(InnerTree,IMsg,Pred,ISource), | |
| 365 | use_position_info_if_not_defined(ISource,CPred,Source), | |
| 366 | ajoin(['&(',PosNr,')F; ',IMsg],Msg). | |
| 367 | get_criteria_tree_info(disjunct_true(PosNr,DPred,InnerTree),Msg,Pred,Source) :- !, | |
| 368 | get_criteria_tree_info(InnerTree,IMsg,Pred,ISource), | |
| 369 | use_position_info_if_not_defined(ISource,DPred,Source), | |
| 370 | ajoin(['or(',PosNr,')T; ',IMsg],Msg). | |
| 371 | get_criteria_tree_info(disjunct_false(PosNr,DPred,InnerTree),Msg,Pred,Source) :- !, | |
| 372 | get_criteria_tree_info(InnerTree,IMsg,Pred,ISource), | |
| 373 | use_position_info_if_not_defined(ISource,DPred,Source), | |
| 374 | ajoin(['or(',PosNr,')F; ',IMsg],Msg). | |
| 375 | get_criteria_tree_info(implication_true(PosLR,ImpPred,InnerTree),Msg,Pred,Source) :- !, | |
| 376 | get_criteria_tree_info(InnerTree,IMsg,Pred,ISource), | |
| 377 | use_position_info_if_not_defined(ISource,ImpPred,Source), | |
| 378 | ajoin(['=>(',PosLR,')T; ',IMsg],Msg). | |
| 379 | get_criteria_tree_info(implication_false(PosLR,ImpPred,InnerTree),Msg,Pred,Source) :- !, | |
| 380 | get_criteria_tree_info(InnerTree,IMsg,Pred,ISource), | |
| 381 | use_position_info_if_not_defined(ISource,ImpPred,Source), | |
| 382 | ajoin(['=>(',PosLR,')F; ',IMsg],Msg). | |
| 383 | get_criteria_tree_info(equivalence_true(PosLR,ImpPred,InnerTree),Msg,Pred,Source) :- !, | |
| 384 | get_criteria_tree_info(InnerTree,IMsg,Pred,ISource), | |
| 385 | use_position_info_if_not_defined(ISource,ImpPred,Source), | |
| 386 | ajoin(['<=>(',PosLR,')T; ',IMsg],Msg). | |
| 387 | get_criteria_tree_info(equivalence_false(PosLR,ImpPred,InnerTree),Msg,Pred,Source) :- !, | |
| 388 | get_criteria_tree_info(InnerTree,IMsg,Pred,ISource), | |
| 389 | use_position_info_if_not_defined(ISource,ImpPred,Source), | |
| 390 | ajoin(['<=>(',PosLR,')F; ',IMsg],Msg). | |
| 391 | get_criteria_tree_info(negation(X),Msg,Pred,Source) :- !, | |
| 392 | get_criteria_tree_info(X,IMsg,Pred,Source), | |
| 393 | ajoin(['neg: ',IMsg],Msg). | |
| 394 | get_criteria_tree_info(T,'UNKNOWN',error,'') :- add_internal_error('Unknown Info Tree: ',T). | |
| 395 | ||
| 396 | ||
| 397 | ||
| 398 | % -------------------------------- | |
| 399 | ||
| 400 | % Not really MCDC: look at individual invariants and which ones are false in some state | |
| 401 | ||
| 402 | :- use_module(probsrc(translate),[set_unicode_mode/0, unset_unicode_mode/0]). | |
| 403 | tcltk_get_invariant_coverage(list([list(['INVARIANT','VALUE','State ID','Source'])|ResList])) :- | |
| 404 | enter_new_error_scope(L,tcltk_get_invariant_coverage), | |
| 405 | b_get_invariant_from_machine(Invariant), | |
| 406 | conjunction_to_list(Invariant,InvList), | |
| 407 | set_unicode_mode, | |
| 408 | call_cleanup(findall(list([TS,Value,ID,PosInfo]),analyse_inv(normal,InvList,TS,Value,ID,PosInfo),ResList), | |
| 409 | unset_unicode_mode), | |
| 410 | exit_error_scope(L,_ErrOcc,tcltk_get_invariant_coverage). | |
| 411 | ||
| 412 | analyse_inv(Style,InvList,TS,Value,ID,PosInfo) :- | |
| 413 | member(Inv,InvList), | |
| 414 | translate_bexpression_with_limit(Inv,100,TS), | |
| 415 | get_position_info(Inv,PosInfo), | |
| 416 | analyse_individual_invariant(Style,Inv,Value,ID). | |
| 417 | ||
| 418 | ||
| 419 | :- use_module(probsrc(state_space), [ visited_expression/2 | |
| 420 | , is_initial_state_id/1 | |
| 421 | % , invariant_not_yet_checked/1 | |
| 422 | , not_invariant_checked/1 | |
| 423 | , invariant_violated/1 | |
| 424 | , not_all_transitions_added/1 | |
| 425 | , max_reached_or_timeout_for_node/1 | |
| 426 | ]). | |
| 427 | :- use_module(probsrc(tcltk_interface), [find_invariant_violation_among_not_checked_nodes/1]). | |
| 428 | analyse_individual_invariant(Style,Inv,'FALSE',ID) :- | |
| 429 | (invariant_violated(ID) | |
| 430 | ; | |
| 431 | Style \= quick, | |
| 432 | not_invariant_checked(ID), % also check seen distinct states, where invariant not processed | |
| 433 | find_invariant_violation_among_not_checked_nodes(ID) % compute invariant; store result | |
| 434 | ; | |
| 435 | Style=precise, not_all_transitions_added(ID) | |
| 436 | ), | |
| 437 | visited_expression(ID,State), | |
| 438 | state_corresponds_to_initialised_b_machine(State,CurBState), | |
| 439 | \+ b_interpreter:check_invariant_predicate_with_time_out(ID,Inv,CurBState), | |
| 440 | !. | |
| 441 | analyse_individual_invariant(_,_Inv,'TRUE',ID) :- | |
| 442 | (is_initial_state_id(ID) -> true ; ID='none'). | |
| 443 | ||
| 444 | ||
| 445 | ||
| 446 | ||
| 447 |