Commit 81dcc7dd authored by POTTIER Francois's avatar POTTIER Francois

Merge remote-tracking branch 'origin/fix'

This modifies the analyses in [Grammar] to use [Fix] as the fixed point
computation algorithm.
parents 0f324090 7e608c59
(* The Boolean lattice. *)
type property =
bool
let bottom =
false
let equal (b1 : bool) (b2 : bool) =
b1 = b2
let is_maximal b =
b
include Fix.PROPERTY with type property = bool
(* The natural numbers, completed with [Infinity], and ordered towards
zero (i.e. [Infinity] is [bottom], [Finite 0] is [top]). *)
type t =
| Finite of int
| Infinity
type property =
t
let equal p1 p2 =
match p1, p2 with
| Finite i1, Finite i2 ->
i1 = i2
| Infinity, Infinity ->
true
| _, _ ->
false
let bottom =
Infinity
let is_maximal p =
match p with
| Finite 0 ->
true
| _ ->
false
let min p1 p2 =
match p1, p2 with
| Finite i1, Finite i2 ->
if i1 <= i2 then p1 else p2
| p, Infinity
| Infinity, p ->
p
let min_lazy p1 p2 =
match p1 with
| Finite 0 ->
p1
| _ ->
min p1 (Lazy.force p2)
let add p1 p2 =
match p1, p2 with
| Finite i1, Finite i2 ->
Finite (i1 + i2)
| _, _ ->
Infinity
let add_lazy p1 p2 =
match p1 with
| Infinity ->
Infinity
| _ ->
add p1 (Lazy.force p2)
let print p =
match p with
| Finite i ->
string_of_int i
| Infinity ->
"infinity"
(* The natural numbers, completed with [Infinity], and ordered towards
zero (i.e. [Infinity] is [bottom], [Finite 0] is [top]). *)
type t =
| Finite of int
| Infinity
include Fix.PROPERTY with type property = t
val min: t -> t -> t
val add: t -> t -> t
val min_lazy: t -> t Lazy.t -> t
val add_lazy: t -> t Lazy.t -> t
val print: t -> string
(* This is an enriched version of [CompletedNat], where we compute not just
numbers, but also lists of matching length. During the fixed point
computation, instead of manipulating actual lists, we manipulate only
recipes for constructing lists. These recipes can be evaluated by the user
after the fixed point has been reached. *)
(* A property is either [Finite (n, xs)], where [n] is a natural number and
[xs] is a (recipe for constructing a) list of length [n]; or [Infinity]. *)
type 'a t =
| Finite of int * 'a list Lazy.t
| Infinity
let equal p1 p2 =
match p1, p2 with
| Finite (i1, _), Finite (i2, _) ->
i1 = i2
| Infinity, Infinity ->
true
| _, _ ->
false
let bottom =
Infinity
let is_maximal p =
match p with
| Finite (0, _) ->
true
| _ ->
false
let min p1 p2 =
match p1, p2 with
| Finite (i1, _), Finite (i2, _) ->
if i1 <= i2 then p1 else p2
| p, Infinity
| Infinity, p ->
p
let min_lazy p1 p2 =
match p1 with
| Finite (0, _) ->
p1
| _ ->
min p1 (Lazy.force p2)
let add p1 p2 =
match p1, p2 with
| Finite (i1, xs1), Finite (i2, xs2) ->
Finite (
i1 + i2,
(* The only list operation in the code! *)
lazy (Lazy.force xs1 @ Lazy.force xs2)
)
| _, _ ->
Infinity
let add_lazy p1 p2 =
match p1 with
| Infinity ->
Infinity
| _ ->
add p1 (Lazy.force p2)
let print conv p =
match p with
| Finite (i, xs) ->
string_of_int i ^ " " ^
String.concat " " (List.map conv (Lazy.force xs))
| Infinity ->
"infinity"
(* This is an enriched version of [CompletedNat], where we compute not just
numbers, but also lists of matching length. During the fixed point
computation, instead of manipulating actual lists, we manipulate only
recipes for constructing lists. These recipes can be evaluated by the user
after the fixed point has been reached. *)
(* A property is either [Finite (n, xs)], where [n] is a natural number and
[xs] is a (recipe for constructing a) list of length [n]; or [Infinity]. *)
type 'a t =
| Finite of int * 'a list Lazy.t
| Infinity
val bottom: 'a t
val equal: 'a t -> 'b t -> bool
val is_maximal: 'a t -> bool
val min: 'a t -> 'a t -> 'a t
val add: 'a t -> 'a t -> 'a t
val min_lazy: 'a t -> 'a t Lazy.t -> 'a t
val add_lazy: 'a t -> 'a t Lazy.t -> 'a t
val print: ('a -> string) -> 'a t -> string
(* BEGIN PERSISTENT_MAPS *)
module type PERSISTENT_MAPS = sig
type key
type 'data t
val empty: 'data t
val add: key -> 'data -> 'data t -> 'data t
val find: key -> 'data t -> 'data
val iter: (key -> 'data -> unit) -> 'data t -> unit
end
(* END PERSISTENT_MAPS *)
(* BEGIN IMPERATIVE_MAPS *)
module type IMPERATIVE_MAPS = sig
type key
type 'data t
val create: unit -> 'data t
val clear: 'data t -> unit
val add: key -> 'data -> 'data t -> unit
val find: key -> 'data t -> 'data
val iter: (key -> 'data -> unit) -> 'data t -> unit
end
(* END IMPERATIVE_MAPS *)
(* BEGIN IMPERATIVE_MAP *)
module type IMPERATIVE_MAP = sig
type key
type data
val set: key -> data -> unit
val get: key -> data option
end
(* END IMPERATIVE_MAP *)
module PersistentMapsToImperativeMaps
(M : PERSISTENT_MAPS)
: IMPERATIVE_MAPS with type key = M.key
and type 'data t = 'data M.t ref
= struct
type key =
M.key
type 'data t =
'data M.t ref
let create () =
ref M.empty
let clear t =
t := M.empty
let add k d t =
t := M.add k d !t
let find k t =
M.find k !t
let iter f t =
M.iter f !t
end
module ImperativeMapsToImperativeMap
(M : IMPERATIVE_MAPS)
(D : sig type data end)
: IMPERATIVE_MAP with type key = M.key
and type data = D.data
= struct
type key =
M.key
type data =
D.data
let m =
M.create()
let set k d =
M.add k d m
let get k =
try
Some (M.find k m)
with Not_found ->
None
end
module ConsecutiveIntegerKeysToImperativeMaps
(K : sig val n: int end)
: IMPERATIVE_MAPS with type key = int
and type 'data t = 'data option array
= struct
open K
type key =
int
type 'data t =
'data option array
let create () =
Array.make n None
let clear m =
Array.fill m 0 n None
let add key data m =
m.(key) <- Some data
let find key m =
match m.(key) with
| None ->
raise Not_found
| Some data ->
data
let iter f m =
Array.iteri (fun key data ->
match data with
| None ->
()
| Some data ->
f key data
) m
end
module HashTableAsImperativeMaps
(H : Hashtbl.HashedType)
: IMPERATIVE_MAPS with type key = H.t
= struct
include Hashtbl.Make(H)
let create () =
create 1023
let add key data table =
add table key data
let find table key =
find key table
end
module TrivialHashedType
(T : sig type t end)
: Hashtbl.HashedType with type t = T.t
= struct
include T
let equal =
(=)
let hash =
Hashtbl.hash
end
(* This module defines three signatures for association maps, together
with a number of conversion functors. *)
(* Following the convention of the ocaml standard library, the [find]
functions raise [Not_found] when the key is not a member of the
domain of the map. By contrast, [get] returns an option. *)
(* BEGIN PERSISTENT_MAPS *)
module type PERSISTENT_MAPS = sig
type key
type 'data t
val empty: 'data t
val add: key -> 'data -> 'data t -> 'data t
val find: key -> 'data t -> 'data
val iter: (key -> 'data -> unit) -> 'data t -> unit
end
(* END PERSISTENT_MAPS *)
(* BEGIN IMPERATIVE_MAPS *)
module type IMPERATIVE_MAPS = sig
type key
type 'data t
val create: unit -> 'data t
val clear: 'data t -> unit
val add: key -> 'data -> 'data t -> unit
val find: key -> 'data t -> 'data
val iter: (key -> 'data -> unit) -> 'data t -> unit
end
(* END IMPERATIVE_MAPS *)
(* BEGIN IMPERATIVE_MAP *)
module type IMPERATIVE_MAP = sig
type key
type data
val set: key -> data -> unit
val get: key -> data option
end
(* END IMPERATIVE_MAP *)
(* An implementation of persistent maps can be made to satisfy the interface
of imperative maps. An imperative map is represented as a persistent map,
wrapped within a reference cell. *)
module PersistentMapsToImperativeMaps
(M : PERSISTENT_MAPS)
: IMPERATIVE_MAPS with type key = M.key
and type 'data t = 'data M.t ref
(* An implementation of imperative maps can be made to satisfy the interface
of a single imperative map. This map is obtained via a single call to [create]. *)
module ImperativeMapsToImperativeMap
(M : IMPERATIVE_MAPS)
(D : sig type data end)
: IMPERATIVE_MAP with type key = M.key
and type data = D.data
(* An implementation of imperative maps as arrays is possible if keys
are consecutive integers. *)
module ConsecutiveIntegerKeysToImperativeMaps
(K : sig val n: int end)
: IMPERATIVE_MAPS with type key = int
and type 'data t = 'data option array
(* An implementation of imperative maps as a hash table. *)
module HashTableAsImperativeMaps
(H : Hashtbl.HashedType)
: IMPERATIVE_MAPS with type key = H.t
(* A trivial implementation of equality and hashing. *)
module TrivialHashedType
(T : sig type t end)
: Hashtbl.HashedType with type t = T.t
......@@ -187,14 +187,14 @@ let rec follow1 tok derivation offset' = function
at the moment, so let's skip it. *)
derivation
| (item, _, offset) :: configs ->
let _, _, rhs, pos, length = Item.def item in
let prod, _, rhs, pos, length = Item.def item in
if offset = offset' then
(* This is an epsilon transition. Attack a new line and add
a comment that explains why the lookahead symbol is
produced or inherited. *)
let nullable, first = Analysis.nullable_first_rhs rhs (pos + 1) in
let nullable, first = Analysis.nullable_first_prod prod (pos + 1) in
if TerminalSet.mem tok first then
......@@ -304,7 +304,7 @@ let explain_reduce_item
if pos < length then
match rhs.(pos) with
| Symbol.N nt ->
let nullable, first = Analysis.nullable_first_rhs rhs (pos + 1) in
let nullable, first = Analysis.nullable_first_prod prod (pos + 1) in
let first : bool = TerminalSet.mem tok first in
let lookahead' =
if nullable then first || lookahead else first
......
......@@ -277,6 +277,18 @@ module TerminalSet = struct
)
)
(* The following definitions are used in the computation of FIRST sets
below. They are not exported outside of this file. *)
type property =
t
let bottom =
empty
let is_maximal _ =
false
end
(* Maps over terminals. *)
......@@ -492,6 +504,18 @@ module Production = struct
in
loop accu k
(* This funny variant is lazy. If at some point [f] does not demand its
second argument, then iteration stops. *)
let foldnt_lazy (nt : Nonterminal.t) (f : index -> 'a Lazy.t -> 'a) (seed : 'a) : 'a =
let k, k' = ntprods.(nt) in
let rec loop prod seed =
if prod < k' then
f prod (lazy (loop (prod + 1) seed))
else
seed
in
loop k seed
(* Accessors. *)
let def prod =
......@@ -666,37 +690,32 @@ module ProductionMap = struct
end
(* ------------------------------------------------------------------------ *)
(* Build the grammar's forward and backward reference graphs.
(* If requested, build and print the forward reference graph of the grammar.
There is an edge of a nonterminal symbol [nt1] to every nonterminal symbol
[nt2] that occurs in the definition of [nt1]. *)
In the backward reference graph, edges relate each nonterminal [nt]
to each of the nonterminals whose definition mentions [nt]. The
reverse reference graph is used in the computation of the nullable,
nonempty, and FIRST sets.
let () =
if Settings.graph then begin
The forward reference graph is unused but can be printed on demand. *)
(* Allocate. *)
let forward : NonterminalSet.t array =
Array.make Nonterminal.n NonterminalSet.empty
let forward : NonterminalSet.t array =
Array.make Nonterminal.n NonterminalSet.empty
in
let backward : NonterminalSet.t array =
Array.make Nonterminal.n NonterminalSet.empty
(* Populate. *)
let () =
Array.iter (fun (nt1, rhs) ->
Array.iter (function
| Symbol.T _ ->
()
| Symbol.N nt2 ->
forward.(nt1) <- NonterminalSet.add nt2 forward.(nt1);
backward.(nt2) <- NonterminalSet.add nt1 backward.(nt2)
) rhs
) Production.table
Array.iter (fun (nt1, rhs) ->
Array.iter (function
| Symbol.T _ ->
()
| Symbol.N nt2 ->
forward.(nt1) <- NonterminalSet.add nt2 forward.(nt1)
) rhs
) Production.table;
(* ------------------------------------------------------------------------ *)
(* If requested, dump the forward reference graph. *)
(* Print. *)
let () =
if Settings.graph then
let module P = Dot.Print (struct
type vertex = Nonterminal.t
let name nt =
......@@ -714,37 +733,179 @@ let () =
P.print f;
close_out f
end
(* ------------------------------------------------------------------------ *)
(* Generic support for fixpoint computations.
A fixpoint computation associates a property with every nonterminal.
A monotone function tells how properties are computed. [compute nt]
updates the property associated with nonterminal [nt] and returns a
flag that tells whether the property actually needed an update. The
state of the computation is maintained entirely inside [compute] and
is invisible here.
Whenever a property of [nt] is updated, the properties of the
terminals whose definitions depend on [nt] are updated. The
dependency graph must be explicitly supplied. *)
let fixpoint (dependencies : NonterminalSet.t array) (compute : Nonterminal.t -> bool) : unit =
let queue : Nonterminal.t Queue.t = Queue.create () in
let onqueue : bool array = Array.make Nonterminal.n true in
for i = 0 to Nonterminal.n - 1 do
Queue.add i queue
done;
Misc.qiter (fun nt ->
onqueue.(nt) <- false;
let changed = compute nt in
if changed then
NonterminalSet.iter (fun nt ->
if not onqueue.(nt) then begin
Queue.add nt queue;
onqueue.(nt) <- true
end
) dependencies.(nt)
) queue
(* Support for analyses of the grammar, expressed as fixed point computations.
We exploit the generic fixed point algorithm in [Fix]. *)
(* We perform memoization only at nonterminal symbols. We assume that the
analysis of a symbol is the analysis of its definition (as opposed to,
say, a computation that depends on the occurrences of this symbol in
the grammar). *)
module GenericAnalysis
(P : Fix.PROPERTY)
(S : sig
open P
(* An analysis is specified by the following functions. *)
(* [terminal] maps a terminal symbol to a property. *)
val terminal: Terminal.t -> property
(* [disjunction] abstracts a binary alternative. That is, when we analyze
an alternative between several productions, we compute a property for
each of them independently, then we combine these properties using
[disjunction]. *)
val disjunction: property -> property Lazy.t -> property
(* [P.bottom] should be a neutral element for [disjunction]. We use it in
the analysis of an alternative with zero branches. *)
(* [conjunction] abstracts a binary sequence. That is, when we analyze a
sequence, we compute a property for each member independently, then we
combine these properties using [conjunction]. In general, conjunction
needs access to the first member of the sequence (a symbol), not just
to its analysis (a property). *)
val conjunction: Symbol.t -> property -> property Lazy.t -> property
(* [epsilon] abstracts the empty sequence. It should be a neutral element
for [conjunction]. *)
val epsilon: property
end)
: sig
open P
(* The results of the analysis take the following form. *)
(* To every nonterminal symbol, we associate a property. *)
val nonterminal: Nonterminal.t -> property
(* To every symbol, we associate a property. *)
val symbol: Symbol.t -> property
(* To every suffix of every production, we associate a property.
The offset [i], which determines the beginning of the suffix,
must be contained between [0] and [n], inclusive, where [n]
is the length of the production. *)
val production: Production.index -> int -> property
end = struct
open P
(* The following analysis functions are parameterized over [get], which allows
making a recursive call to the analysis at a nonterminal symbol. [get] maps
a nonterminal symbol to a property. *)
(* Analysis of a symbol. *)
let symbol sym get : property =
match sym with
| Symbol.T tok ->
S.terminal tok
| Symbol.N nt ->
(* Recursive call to the analysis, via [get]. *)
get nt
(* Analysis of (a suffix of) a production [prod], starting at index [i]. *)
let production prod i get : property =
let rhs = Production.rhs prod in
let n = Array.length rhs in
(* Conjunction over all symbols in the right-hand side. This can be viewed
as a version of [Array.fold_right], which does not necessarily begin at
index [0]. Note that, because [conjunction] is lazy, it is possible
to stop early. *)
let rec loop i =
if i = n then
S.epsilon
else
let sym = rhs.(i) in
S.conjunction sym
(symbol sym get)
(lazy (loop (i+1)))
in
loop i
(* The analysis is the least fixed point of the following function, which
analyzes a nonterminal symbol by looking up and analyzing its definition
as a disjunction of conjunctions of symbols. *)
let nonterminal nt get : property =
(* Disjunction over all productions for this nonterminal symbol. *)
Production.foldnt_lazy nt (fun prod rest ->