Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
POTTIER Francois
menhir
Commits
7662ce58
Commit
7662ce58
authored
Jul 06, 2015
by
POTTIER Francois
Browse files
More cleanup.
parent
68b4af50
Changes
1
Hide whitespace changes
Inline
Sidebyside
src/Coverage.ml
View file @
7662ce58
...
...
@@ 371,53 +371,103 @@ let answer : question > P.property =
let
es
=
ref
0
let
backward
(
s'
,
z
)
:
P
.
property
=
let
module
G
=
struct
type
vertex
=
Lr1
.
node
*
Terminal
.
t
(* A vertex is a pair [s, z]. *)
type
vertex
=
Lr1
.
node
*
Terminal
.
t
let
equal
(
s'1
,
z1
)
(
s'2
,
z2
)
=
Lr1
.
Node
.
compare
s'1
s'2
=
0
&&
Terminal
.
compare
z1
z2
=
0
let
hash
(
s
,
z
)
=
Hashtbl
.
hash
(
Lr1
.
number
s
,
z
)
type
label
=
int
*
Terminal
.
t
Seq
.
seq
let
weight
(
w
,
_
)
=
w
let
hash
(
s
,
z
)
=
Hashtbl
.
hash
(
Lr1
.
number
s
,
z
)
(* An edge is labeled with a property of the form [Finite (i, pi)],
that is, a distance [i] and a witness path [pi]. *)
type
label
=
int
*
Terminal
.
t
Seq
.
seq
let
weight
(
w
,
_
)
=
w
(* Backward search from the single source [s', z]. *)
let
sources
f
=
f
(
s'
,
z
)
let
successors
edge
(
s'
,
z
)
=
match
Lr1
.
incoming_symbol
s'
with

None
>
(* A
start symbol
has no predecessors. *)
(* A
n entry state
has no predecessor
state
s. *)
()

Some
(
Symbol
.
T
t
)
>
List
.
iter
(
fun
pred
>
edge
(
1
,
Seq
.
singleton
t
)
(
pred
,
t
)
(* There is an edge from [s] to [s'] labeled [t] in the automaton.
Thus, our graph has an edge from [s', z] to [s, t], labeled [t]. *)
let
label
=
(
1
,
Seq
.
singleton
t
)
in
List
.
iter
(
fun
s
>
edge
label
(
s
,
t
)
)
(
Lr1
.
predecessors
s'
)

Some
(
Symbol
.
N
nt
)
>
List
.
iter
(
fun
pred
>
(* There is an edge from [s] to [s'] labeled [nt] in the automaton.
For every production [prod] associated with [nt], for every
letter [a], we query the analysis for a path that begins in [s]
and leads to reducing [prod] when the lookahead symbol is [z].
Such a path [w] takes us from [s, a] to [s', z]. Thus, our graph
has an edge, labeled [w], in the reverse direction. *)
List
.
iter
(
fun
s
>
Production
.
foldnt
nt
()
(
fun
prod
()
>
TerminalSet
.
iter
(
fun
a
>
match
answer
{
s
=
pred
;
a
=
a
;
prod
=
prod
;
i
=
0
;
z
=
z
}
with
match
answer
{
s
=
s
;
a
=
a
;
prod
=
prod
;
i
=
0
;
z
=
z
}
with

P
.
Infinity
>
()

P
.
Finite
(
w
,
ts
)
>
edge
(
w
,
ts
)
(
pred
,
a
)
edge
(
w
,
ts
)
(
s
,
a
)
)
(
first
prod
0
z
)
)
)
(
Lr1
.
predecessors
s'
)
end
in
let
module
D
=
Dijkstra
.
Make
(
G
)
in
let
module
S
=
struct
exception
Success
of
P
.
property
end
in
(* Search backwards from [s', z], stopping as soon as an entry state
is reached. In that case, return the distance [i] and path [pi]
that have been found. *)
try
let
_
=
D
.
search
(
fun
(
distance
,
(
v'
,
_
)
,
path
)
>
let
_
=
D
.
search
(
fun
(
i
,
(
s
,
_
)
,
labels
)
>
(* Debugging. TEMPORARY *)
incr
es
;
if
!
es
mod
10000
=
0
then
Printf
.
fprintf
stderr
"es = %d
\n
%!"
!
es
;
if
Lr1
.
incoming_symbol
v'
=
None
then
let
path
=
List
.
map
snd
path
in
raise
(
S
.
Success
(
P
.
Finite
(
distance
,
Seq
.
concat
path
)))
(* TEMPORARY keep path *)
(* If [s] is a start state... *)
if
Lr1
.
incoming_symbol
s
=
None
then
(* [labels] is a list of graph labels. Projecting onto the second
component yields a list of paths (sequences of terminal symbols),
which we concatenate to obtain a path. Because the edges that were
followed last are in front of the list, and because this is a
reverse graph, we obtain a path that makes direct sense: it is a
sequence of terminal symbols that will take the automaton into
state [s'] if the next (unconsumed) symbol is [z]. *)
let
path
=
P
.
Finite
(
i
,
Seq
.
concat
(
List
.
map
snd
labels
))
in
raise
(
S
.
Success
path
)
)
in
P
.
bottom
with
S
.
Success
p
>
p
(*  *)
(* For each state [s'] and for each terminal symbol [z] such that [z] triggers
an error in [s'], backward search is performed. For each state [s'], we
stop as soon as one [z] is found, i.e., as soon as one way of causing an
error in state [s'] is found. *)
let
backward
s'
:
P
.
property
=
(* Debugging. TEMPORARY *)
Printf
.
fprintf
stderr
"Attempting to reach an error in state %d:
\n
%!"
(
Lr1
.
number
s'
);
...
...
@@ 429,7 +479,7 @@ let backward s' : P.property =
P
.
bottom
)
(* Test. *)
(* Test.
TEMPORARY
*)
let
()
=
Lr1
.
iter
(
fun
s'
>
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment