34
35:- module(gcover, [gcover/2,
36 covered_db/6,
37 reset_cover/0,
38 reset_cover/1,
39 loc_file_line/4]). 40
41:- use_module(library(filepos_line)). 42:- use_module(library(module_files)). 43:- use_module(library(ontrace)). 44:- use_module(library(ntabling)). 45
46:- table loc_file_line/4. 47
48:- public not_dynamic/1. 49
50:- meta_predicate not_dynamic(0). 51
52not_dynamic(Call) :-
53 \+ predicate_property(Call, dynamic).
54
55:- meta_predicate gcover(0,+). 56
57gcover(Goal, OptL1) :-
58 select_option(tag(Tag), OptL1, OptL, user),
59 ontrace(Goal, gcover_port(Tag), [goal(not_dynamic)|OptL]).
60
61:- dynamic covered_db/6. 62
63gcover_port(Tag, Port, _Frame, _PC, _ParentL, Loc, continue) :-
64 record_cover(Loc, Port, Tag).
65
66file_line_end(Module, File, L1, L2) :-
67 setup_call_cleanup(
68 '$push_input_context'(file_line_end),
69 file_line_end_2(Module, File, L1, L2),
70 '$pop_input_context').
71
72file_line_end_2(Module, File, L1, L2) :-
73 catch(open(File, read, In), _, fail),
74 set_stream(In, newline(detect)),
75 call_cleanup(
76 ( read_source_term_at_location(
77 In, _,
78 [ line(L1),
79 module(Module)
80 ]),
81 stream_property(In, position(Pos)),
82 stream_position_data(line_count, Pos, L2)
83 ),
84 close(In)).
85
86loc_file_line(clause_term_position(ClauseRef, TermPos), File, L1, L2) :-
87 clause_property(ClauseRef, file(File)),
88 file_termpos_line2(File, TermPos, L1, L2).
89loc_file_line(clause(ClauseRef), File, L1, L2) :-
90 clause_property(ClauseRef, file(File)),
91 clause_property(ClauseRef, line_count(L1)),
92 clause_property(ClauseRef, module(Module)),
93 file_line_end(Module, File, L1, L2).
94loc_file_line(file_term_position(File, TermPos), File, L1, L2) :-
95 file_termpos_line2(File, TermPos, L1, L2).
96loc_file_line(file(File, L1, _, _), File, L1, L2) :-
97 once(module_file(Module, File)),
98 file_line_end(Module, File, L1, L2).
99loc_file_line(clause_pc(Clause, PC), File, L1, L2) :-
100 clause_pc_location(Clause, PC, Loc),
101 loc_file_line(Loc, File, L1, L2).
102
103file_termpos_line2(File, TermPos, Line1, Line2) :-
104 ( compound(TermPos),
105 arg(1, TermPos, C1),
106 integer(C1),
107 arg(2, TermPos, C2),
108 integer(C2)
109 ->filepos_line(File, C1, Line1, _),
110 filepos_line(File, C2, Line2, _)
111 ; true
112 ).
113
114record_cover(Loc, Port, Tag) :-
115 loc_file_line(Loc, File, Line1, Line2),
116 port_record_cover(Port, File, Line1, Line2, Tag).
117
118port_record_cover(exitcl, File, Line1, Line2, Tag) :- !,
119 decr_record_cover(failure, OutPort, File, Line1, Line2, Tag),
120 incr_record_cover(OutPort, File, Line1, Line2, Tag).
121port_record_cover(unify, File, Line1, Line2, Tag) :- !,
122 incr_record_cover(failure, File, Line1, Line2, Tag).
124port_record_cover(redo(0), File, Line1, Line2, Tag) :- !,
125 incr_record_cover(redo, File, Line1, Line2, Tag).
126port_record_cover(redo(_), File, Line1, Line2, Tag) :- !,
127 incr_record_cover(redoi, File, Line1, Line2, Tag).
128
129port_record_cover(Port, File, Line1, Line2, Tag) :-
130 incr_record_cover(Port, File, Line1, Line2, Tag).
131
132incr_record_cover(Port, File, Line1, Line2, Tag) :-
133 ( retract(covered_db(File, Line1, Line2, Port, Tag, Count1))
134 ->succ(Count1, Count)
135 ; Count=1
136 ),
137 assertz(covered_db(File, Line1, Line2, Port, Tag, Count)).
138
139decr_record_cover(Port, OutPort, File, Line1, Line2, Tag) :-
140 ( retract(covered_db(File, Line1, Line2, Port, Tag, Count1))
141 ->succ(Count, Count1),
142 ( Count =:= 0
143 ->true
144 ; assertz(covered_db(File, Line1, Line2, Port, Tag, Count))
145 ),
146 OutPort = (success)
147 ; OutPort = multi
148 ).
149
150reset_cover :- reset_cover(_).
151
152reset_cover(Tag) :-
153 retractall(covered_db(_, _, _, _, Tag, _))