+++ /dev/null
-(**************************************************************************)
-(* *)
-(* Menhir *)
-(* *)
-(* François Pottier, INRIA Rocquencourt *)
-(* Yann Régis-Gianas, PPS, Université Paris Diderot *)
-(* *)
-(* Copyright 2005-2008 Institut National de Recherche en Informatique *)
-(* et en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0, with the change *)
-(* described in file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-open Grammar
-
-(* This module constructs an LR(1) automaton by following Pager's method, that
- is, by merging states on the fly when they are weakly compatible. *)
-
-(* ------------------------------------------------------------------------ *)
-(* Nodes. *)
-
-type node = {
-
- (* A node number, assigned during construction. *)
-
- raw_number: int;
-
- (* A node number, assigned after conflict resolution has taken
- place and after inacessible nodes have been removed. This
- yields sequential numbers, from the client's point of view. *)
-
- mutable number: int;
-
- (* Each node is associated with a state. This state can change
- during construction as nodes are merged. *)
-
- mutable state: Lr0.lr1state;
-
- (* Each node carries information about its outgoing transitions
- and about its reductions. *)
-
- mutable transitions: node SymbolMap.t;
- mutable reductions: Production.index list TerminalMap.t;
-
- (* Tokens for which there are several possible behaviors are
- conflict tokens. *)
-
- mutable conflict_tokens: TerminalSet.t;
-
- (* Transitions are also stored in reverse, so as to allow reverse
- traversals of the automaton. *)
-
- mutable predecessors: node list;
-
- (* If a node has any incoming transitions, then they all carry
- the same symbol. This is it. *)
-
- mutable incoming_symbol: Symbol.t option;
-
- (* Transient marks are used during construction and traversal. *)
-
- mutable mark: Mark.t;
-
- (* (New as of 2012/01/23.) This flag records whether a shift/reduce
- conflict in this node was solved in favor of neither (%nonassoc).
- This is later used to forbid a default reduction at this node. *)
-
- mutable forbid_default_reduction: bool;
-
- }
-
-module Node = struct
- type t = node
- let compare node1 node2 =
- node1.number - node2.number
-end
-
-module NodeSet =
- Set.Make (Node)
-
-module NodeMap =
- Map.Make (Node)
-
-(* ------------------------------------------------------------------------ *)
-
-(* Output debugging information if [--follow-construction] is enabled. *)
-
-let follow_transition (again : bool) (source : node) (symbol : Symbol.t) (state : Lr0.lr1state) =
- if Settings.follow then
- Printf.fprintf stderr
- "%s transition out of state r%d along symbol %s.\nProposed target state:\n%s"
- (if again then "Re-examining" else "Examining")
- source.raw_number
- (Symbol.print symbol)
- (Lr0.print_closure state)
-
-let follow_state (msg : string) (node : node) (print : bool) =
- if Settings.follow then
- Printf.fprintf stderr
- "%s: r%d.\n%s\n"
- msg
- node.raw_number
- (if print then Lr0.print_closure node.state else "")
-
-(* ------------------------------------------------------------------------ *)
-
-(* The following two mutually recursive functions are invoked when the state
- associated with an existing node grows. The node's descendants are examined
- and grown into a fixpoint is reached.
-
- This work is performed in an eager manner: we do not attempt to build any
- new transitions until all existing nodes have been suitably grown. Indeed,
- building new transitions requires making merging decisions, and such
- decisions cannot be made on a sound basis unless all existing nodes have
- been suitably grown. Otherwise, one could run into a dead end where two
- successive, incompatible merging decisions are made, because the
- consequences of the first decision (growing descendant nodes) were not made
- explicit before the second decision was taken. This was a bug in versions
- of Menhir ante 20070520.
-
- Although I wrote this code independently, I later found out that it seems
- quite similar to the code in Karl Schimpf's Ph.D. thesis (1981), page 35.
-
- It is necessary that all existing transitions be explicit before the [grow]
- functions are called. In other words, if it has been decided that there will
- be a transition from [node1] to [node2], then [node1.transitions] must be
- updated before [grow] is invoked. *)
-
-(* [grow node state] grows the existing node [node], if necessary, so that its
- associated state subsumes [state]. If this represents an actual (strict)
- growth, then [node]'s descendants are grown as well. *)
-
-let rec grow node state =
- if Lr0.subsume state node.state then
- follow_state "Target state is unaffected" node false
- else begin
-
- (* In versions of Menhir prior to June 2008, I wrote this:
-
- If I know what I am doing, then the new state that is being
- merged into the existing state should be compatible, in
- Pager's sense, with the existing node. In other words,
- compatibility should be preserved through transitions.
-
- and the code contained this assertion:
-
- assert (Lr0.compatible state node.state);
- assert (Lr0.eos_compatible state node.state);
-
- However, this was wrong. See, for instance, the sample grammars
- cocci.mly and boris-mini.mly. The problem is particularly clearly
- apparent in boris-mini.mly, where it only involves inclusion of
- states -- the definition of Pager's weak compatibility does not
- enter the picture. Here is, roughly, what is going on.
-
- Assume we have built some state A, which, along some symbol S,
- has a transition to itself. This means, in fact, that computing
- the successor of A along S yields a *subset* of A, that is,
- succ(A, S) <= A.
-
- Then, we wish to build a new state A', which turns out to be a
- superset of A, so we decide to grow A. (The fact that A is a
- subset of A' implies that A and A' are Pager-compatible.) As
- per the code below, we immediately update the state A in place,
- to become A'. Then, we inspect the transition along symbol S.
- We find that the state succ(A', S) must be merged into A'.
-
- In this situation, the assertions above require succ(A', S)
- to be compatible with A'. However, this is not necessarily
- the case. By monotonicity of succ, we do have succ(A, S) <=
- succ(A', S). But nothing says that succ(A', S) are related
- with respect to inclusion, or even Pager-compatible. The
- grammar in boris-mini.mly shows that they are not.
-
- *)
-
- (* Grow [node]. *)
-
- node.state <- Lr0.union state node.state;
- follow_state "Growing existing state" node true;
-
- (* Grow [node]'s successors. *)
-
- grow_successors node
-
- end
-
-(* [grow_successors node] grows [node]'s successors. *)
-
-(* Note that, if there is a cycle in the graph, [grow_successors] can be
- invoked several times at a single node [node], with [node.state] taking on
- a new value every time. In such a case, this code should be correct,
- although probably not very efficient. *)
-
-and grow_successors node =
- SymbolMap.iter (fun symbol (successor_node : node) ->
- let successor_state = Lr0.transition symbol node.state in
- follow_transition true node symbol successor_state;
- grow successor_node successor_state
- ) node.transitions
-
-(* ------------------------------------------------------------------------ *)
-
-(* Data structures maintained during the construction of the automaton. *)
-
-(* A queue of pending nodes, whose outgoing transitions have not yet
- been built. *)
-
-let queue : node Queue.t =
- Queue.create()
-
-(* A mapping of LR(0) node numbers to lists of nodes. This allows us to
- efficiently find all existing nodes that are core-compatible with a
- newly found state. *)
-
-let map : node list array =
- Array.create Lr0.n []
-
-(* A counter that allows assigning raw numbers to nodes. *)
-
-let num =
- ref 0
-
-(* ------------------------------------------------------------------------ *)
-
-(* [create state] creates a new node that stands for the state [state].
- It is expected that [state] does not subsume, and is not subsumed by,
- any existing state. *)
-
-let create (state : Lr0.lr1state) : node =
-
- (* Allocate a new node. *)
-
- let node = {
- state = state;
- transitions = SymbolMap.empty;
- reductions = TerminalMap.empty;
- conflict_tokens = TerminalSet.empty;
- raw_number = Misc.postincrement num;
- number = 0; (* temporary placeholder *)
- mark = Mark.none;
- predecessors = [];
- incoming_symbol = None;
- forbid_default_reduction = false;
- } in
-
- (* Update the mapping of LR(0) cores to lists of nodes. *)
-
- let k = Lr0.core state in
- assert (k < Lr0.n);
- map.(k) <- node :: map.(k);
-
- (* Enqueue this node for further examination. *)
-
- Queue.add node queue;
-
- (* Debugging output. *)
-
- follow_state "Creating a new state" node false;
-
- (* Return the freshly created node. *)
-
- node
-
-(* ------------------------------------------------------------------------ *)
-
-(* Materializing a transition turns its target state into a (fresh or
- existing). There are three scenarios: the proposed new state can be
- subsumed by an existing state, compatible with an existing state, or
- neither. *)
-
-exception Subsumed of node
-
-exception Compatible of node
-
-let materialize (source : node) (symbol : Symbol.t) (target : Lr0.lr1state) : unit =
- try
-
- (* Debugging output. *)
-
- follow_transition false source symbol target;
-
- (* Find all existing core-compatible states. *)
-
- let k = Lr0.core target in
- assert (k < Lr0.n);
- let similar = map.(k) in
-
- (* Check whether one of these states subsumes the candidate new state. If
- so, there is no need to create a new node: just reuse the existing
- one. *)
-
- (* 20110124: require error compatibility in addition to subsumption. *)
-
- List.iter (fun node ->
- if Lr0.subsume target node.state &&
- Lr0.error_compatible target node.state then
- raise (Subsumed node)
- ) similar;
-
- (* Check whether one of the existing states is compatible, in Pager's
- sense, with the new state. If so, there is no need to create a new
- state: just merge the new state into the existing one. *)
-
- (* 20110124: require error compatibility in addition to the existing
- compatibility criteria. *)
-
- if Settings.pager then
- List.iter (fun node ->
- if Lr0.compatible target node.state &&
- Lr0.eos_compatible target node.state &&
- Lr0.error_compatible target node.state then
- raise (Compatible node)
- ) similar;
-
- (* Both of the above checks have failed. Create a new node. Two states
- that are in the subsumption relation are also compatible. This implies
- that the newly created node does not subsume any existing states. *)
-
- source.transitions <- SymbolMap.add symbol (create target) source.transitions
-
- with
-
- | Subsumed node ->
-
- (* Join an existing target node. *)
-
- follow_state "Joining existing state" node false;
- source.transitions <- SymbolMap.add symbol node source.transitions
-
- | Compatible node ->
-
- (* Join and grow an existing target node. It seems important that the
- new transition is created before [grow_successors] is invoked, so
- that all transition decisions made so far are explicit. *)
-
- node.state <- Lr0.union target node.state;
- follow_state "Joining and growing existing state (Pager says, fine)" node true;
- source.transitions <- SymbolMap.add symbol node source.transitions;
- grow_successors node
-
-(* ------------------------------------------------------------------------ *)
-
-(* The actual construction process. *)
-
-(* Populate the queue with the start nodes and store them in an array. *)
-
-let entry : node ProductionMap.t =
- ProductionMap.map (fun (k : Lr0.node) ->
- create (Lr0.start k)
- ) Lr0.entry
-
-(* Pick a node in the queue, that is, a node whose transitions have not yet
- been built. Build these transitions, and continue. *)
-
-(* Note that building a transition can cause existing nodes to grow, so
- [node.state] is not necessarily invariant throughout the inner loop. *)
-
-let () =
- Misc.qiter (fun node ->
- List.iter (fun symbol ->
- materialize node symbol (Lr0.transition symbol node.state)
- ) (Lr0.outgoing_symbols (Lr0.core node.state))
- ) queue
-
-(* Record how many nodes were constructed. *)
-
-let n =
- !num
-
-let () =
- Error.logA 1 (fun f -> Printf.fprintf f "Built an LR(1) automaton with %d states.\n" !num)
-
-(* ------------------------------------------------------------------------ *)
-(* We now perform one depth-first traversal of the automaton,
- recording predecessor edges, numbering nodes, sorting nodes
- according to their incoming symbol, building reduction tables, and
- finding out which nodes have conflicts. *)
-
-(* A count of all nodes. *)
-
-let () =
- num := 0
-
-(* A list of all nodes. *)
-
-let nodes : node list ref =
- ref []
-
-(* A list of nodes with conflicts. *)
-
-let conflict_nodes : node list ref =
- ref []
-
-(* Counts of nodes with shift/reduce and reduce/reduce conflicts. *)
-
-let shift_reduce =
- ref 0
-
-let reduce_reduce =
- ref 0
-
-(* Count of the shift/reduce conflicts that could be silently
- resolved. *)
-
-let silently_solved =
- ref 0
-
-(* A mapping of symbols to lists of nodes that admit this incoming
- symbol. *)
-
-let incoming : node list SymbolMap.t ref =
- ref SymbolMap.empty
-
-(* Go ahead. *)
-
-let () =
-
- let marked = Mark.fresh() in
-
- let rec visit node =
- if not (Mark.same node.mark marked) then begin
- node.mark <- marked;
- nodes := node :: !nodes;
-
- (* Number this node. *)
-
- let number = !num in
- num := number + 1;
- node.number <- number;
-
- (* Insertion of a new reduce action into the table of reductions. *)
-
- let addl prod tok reductions =
- let prods =
- try
- TerminalMap.lookup tok reductions
- with Not_found ->
- []
- in
- TerminalMap.add tok (prod :: prods) reductions
- in
-
- (* Build the reduction table. Here, we gather all potential
- reductions, without attempting to solve shift/reduce
- conflicts on the fly, because that would potentially hide
- shift/reduce/reduce conflicts, which we want to be aware
- of. *)
-
- let reductions =
- List.fold_left (fun reductions (toks, prod) ->
- TerminalSet.fold (addl prod) toks reductions
- ) TerminalMap.empty (Lr0.reductions node.state)
- in
-
- (* Detect conflicts. Attempt to solve shift/reduce conflicts
- when unambiguously allowed by priorities. *)
-
- let has_shift_reduce = ref false
- and has_reduce_reduce = ref false in
-
- node.reductions <-
- TerminalMap.fold (fun tok prods reductions ->
- if SymbolMap.mem (Symbol.T tok) node.transitions then begin
-
- (* There is a transition in addition to the reduction(s). We
- have (at least) a shift/reduce conflict. *)
-
- assert (not (Terminal.equal tok Terminal.sharp));
- match prods with
- | [] ->
- assert false
- | [ prod ] ->
- begin
-
- (* This is a single shift/reduce conflict. If priorities tell
- us how to solve it, we follow that and modify the automaton. *)
-
- match Precedence.shift_reduce tok prod with
-
- | Precedence.ChooseShift ->
-
- (* Suppress the reduce action. *)
-
- incr silently_solved;
- reductions
-
- | Precedence.ChooseReduce ->
-
- (* Record the reduce action and suppress the shift transition.
- The automaton is modified in place. This can have the subtle
- effect of making some nodes unreachable. Any conflicts in these
- nodes will then be ignored (as they should be). *)
-
- incr silently_solved;
- node.transitions <- SymbolMap.remove (Symbol.T tok) node.transitions;
- TerminalMap.add tok prods reductions
-
- | Precedence.ChooseNeither ->
-
- (* Suppress the reduce action and the shift transition. *)
-
- incr silently_solved;
- node.transitions <- SymbolMap.remove (Symbol.T tok) node.transitions;
- node.forbid_default_reduction <- true;
- reductions
-
- | Precedence.DontKnow ->
-
- (* Priorities don't allow concluding. Record the
- existence of a shift/reduce conflict. *)
-
- node.conflict_tokens <- Grammar.TerminalSet.add tok node.conflict_tokens;
- has_shift_reduce := true;
- TerminalMap.add tok prods reductions
-
- end
-
- | prod1 :: prod2 :: _ ->
-
- (* This is a shift/reduce/reduce conflict. If the priorities
- are such that each individual shift/reduce conflict is solved
- in favor of shifting or in favor of neither, then solve the entire
- composite conflict in the same way. Otherwise, report the conflict. *)
-
- let choices = List.map (Precedence.shift_reduce tok) prods in
-
- if List.for_all (fun choice ->
- match choice with
- | Precedence.ChooseShift -> true
- | _ -> false
- ) choices then begin
-
- (* Suppress the reduce action. *)
-
- silently_solved := !silently_solved + List.length prods;
- reductions
-
- end
- else if List.for_all (fun choice ->
- match choice with
- | Precedence.ChooseNeither -> true
- | _ -> false
- ) choices then begin
-
- (* Suppress the reduce action and the shift transition. *)
-
- silently_solved := !silently_solved + List.length prods;
- node.transitions <- SymbolMap.remove (Symbol.T tok) node.transitions;
- reductions
-
- end
- else begin
-
- (* Record a shift/reduce/reduce conflict. Keep all reductions. *)
-
- node.conflict_tokens <- Grammar.TerminalSet.add tok node.conflict_tokens;
- has_shift_reduce := true;
- has_reduce_reduce := true;
- TerminalMap.add tok prods reductions
-
- end
-
- end
- else
- let () =
- match prods with
- | []
- | [ _ ] ->
- ()
- | prod1 :: prod2 :: _ ->
-
- (* There is no transition in addition to the reduction(s). We
- have a pure reduce/reduce conflict. Do nothing about it at
- this point. *)
-
- node.conflict_tokens <- Grammar.TerminalSet.add tok node.conflict_tokens;
- has_reduce_reduce := true
-
- in
- TerminalMap.add tok prods reductions
-
- ) reductions TerminalMap.empty;
-
- (* Record statistics about conflicts. *)
-
- if not (TerminalSet.is_empty node.conflict_tokens) then begin
- conflict_nodes := node :: !conflict_nodes;
- if !has_shift_reduce then
- incr shift_reduce;
- if !has_reduce_reduce then
- incr reduce_reduce
- end;
-
- (* Continue the depth-first traversal. Record predecessors edges
- as we go. No ancestor appears twice in a list of
- predecessors, because two nodes cannot be related by two
- edges that carry distinct symbols. *)
-
- SymbolMap.iter (fun symbol son ->
- begin
- match son.incoming_symbol with
- | None ->
- son.incoming_symbol <- Some symbol;
- let others =
- try
- SymbolMap.find symbol !incoming
- with Not_found ->
- []
- in
- incoming := SymbolMap.add symbol (son :: others) !incoming
- | Some symbol' ->
- assert (Symbol.equal symbol symbol')
- end;
- son.predecessors <- node :: son.predecessors;
- visit son
- ) node.transitions
- end
- in
-
- ProductionMap.iter (fun _ node -> visit node) entry
-
-let nodes =
- List.rev !nodes (* list is now sorted by increasing node numbers *)
-
-let conflict_nodes =
- !conflict_nodes
-
-let incoming =
- !incoming
-
-let () =
- if !silently_solved = 1 then
- Error.logA 1 (fun f -> Printf.fprintf f "One shift/reduce conflict was silently solved.\n")
- else if !silently_solved > 1 then
- Error.logA 1 (fun f -> Printf.fprintf f "%d shift/reduce conflicts were silently solved.\n" !silently_solved);
- if !num < n then
- Error.logA 1 (fun f -> Printf.fprintf f "Only %d states remain after resolving shift/reduce conflicts.\n" !num)
-
-let () =
- Grammar.diagnostics()
-
-let n =
- !num
-
-let forbid_default_reduction node =
- node.forbid_default_reduction
-
-(* ------------------------------------------------------------------------ *)
-(* Breadth-first iteration over all nodes. *)
-
-let bfs =
- let module B = Breadth.Make (struct
- type vertex = node
- type label = Symbol.t
- let set_mark node m = node.mark <- m
- let get_mark node = node.mark
- let entry f = ProductionMap.iter (fun _ node -> f node) entry
- let successors f node = SymbolMap.iter f node.transitions
- end) in
- B.search
-
-(* ------------------------------------------------------------------------ *)
-(* Iteration over all nodes. *)
-
-let fold f accu =
- List.fold_left f accu nodes
-
-let iter f =
- fold (fun () node -> f node) ()
-
-let map f =
- List.map f nodes
-
-let foldx f =
- fold (fun accu node ->
- match node.incoming_symbol with
- | None -> accu
- | Some _ -> f accu node)
-
-let iterx f =
- iter (fun node ->
- match node.incoming_symbol with
- | None -> ()
- | Some _ -> f node)
-
-(* -------------------------------------------------------------------------- *)
-(* Our output channel. *)
-
-let out =
- lazy (open_out (Settings.base ^ ".automaton"))
-
-(* ------------------------------------------------------------------------ *)
-(* If requested, dump a verbose description of the automaton. *)
-
-let () =
- Time.tick "Construction of the LR(1) automaton";
- if Settings.dump then begin
- fold (fun () node ->
- let out = Lazy.force out in
- Printf.fprintf out "State %d%s:\n%s"
- node.number
- (if Settings.follow then Printf.sprintf " (r%d)" node.raw_number else "")
- (Lr0.print node.state);
- SymbolMap.iter (fun symbol node ->
- Printf.fprintf out "-- On %s shift to state %d\n"
- (Symbol.print symbol) node.number
- ) node.transitions;
- TerminalMap.iter (fun tok prods ->
- List.iter (fun prod ->
- (* TEMPORARY factoriser les symboles qui conduisent a reduire une meme production *)
- Printf.fprintf out "-- On %s " (Terminal.print tok);
- match Production.classify prod with
- | Some nt ->
- Printf.fprintf out "accept %s\n" (Nonterminal.print false nt)
- | None ->
- Printf.fprintf out "reduce production %s\n" (Production.print prod)
- ) prods
- ) node.reductions;
- if not (TerminalSet.is_empty node.conflict_tokens) then
- Printf.fprintf out "** Conflict on %s\n" (TerminalSet.print node.conflict_tokens);
- Printf.fprintf out "\n%!"
- ) ();
- Time.tick "Dumping the LR(1) automaton"
- end
-
-(* ------------------------------------------------------------------------ *)
-(* [reverse_dfs goal] performs a reverse depth-first search through
- the automaton, starting at node [goal], and marking the nodes
- traversed. It returns a function that tells whether a node is
- marked, that is, whether a path leads from that node to the goal
- node. *)
-
-let reverse_dfs goal =
-
- let mark = Mark.fresh() in
-
- let marked node =
- Mark.same node.mark mark
- in
-
- let rec visit node =
- if not (marked node) then begin
- node.mark <- mark;
- List.iter visit node.predecessors
- end
- in
-
- visit goal;
- marked
-
-(* ------------------------------------------------------------------------ *)
-(* Iterating over all nodes that are targets of edges carrying a
- certain symbol. The sources of the corresponding edges are also
- provided. *)
-
-let targets f accu symbol =
- let targets =
- try
- SymbolMap.find symbol incoming
- with Not_found ->
- (* There are no incoming transitions on the start symbols. *)
- []
- in
- List.fold_left (fun accu target ->
- f accu target.predecessors target
- ) accu targets
-
-(* ------------------------------------------------------------------------ *)
-(* Converting a start node into the single item that it contains. *)
-
-let start2item node =
- let state : Lr0.lr1state = node.state in
- let core : Lr0.node = Lr0.core state in
- let items : Item.Set.t = Lr0.items core in
- assert (Item.Set.cardinal items = 1);
- Item.Set.choose items
-
-(* ------------------------------------------------------------------------ *)
-(* Accessors. *)
-
-let number node =
- node.number
-
-let state node =
- node.state
-
-let transitions node =
- node.transitions
-
-let reductions node =
- node.reductions
-
-let conflicts f =
- List.iter (fun node ->
- f node.conflict_tokens node
- ) conflict_nodes
-
-let incoming_symbol node =
- node.incoming_symbol
-
-let predecessors node =
- node.predecessors
-
-(* ------------------------------------------------------------------------ *)
-
-(* This inverts a mapping of tokens to productions into a mapping of
- productions to sets of tokens. *)
-
-(* This is needed, in [CodeBackend], to avoid producing two (or more)
- separate branches that call the same [reduce] function. Instead,
- we generate just one branch, guarded by a [POr] pattern. *)
-
-let invert reductions : TerminalSet.t ProductionMap.t =
- TerminalMap.fold (fun tok prods inverse ->
- let prod = Misc.single prods in
- let toks =
- try
- ProductionMap.lookup prod inverse
- with Not_found ->
- TerminalSet.empty
- in
- ProductionMap.add prod (TerminalSet.add tok toks) inverse
- ) reductions ProductionMap.empty
-
-(* ------------------------------------------------------------------------ *)
-(* Computing which terminal symbols a state is willing to act upon.
-
- This function is currently unused, but could be used as part of an error
- reporting system.
-
- One must keep in mind that, due to the merging of states, a state might be
- willing to perform a reduction on a certain token, yet the reduction can
- take us to another state where this token causes an error. In other words,
- the set of terminal symbols that is computed here is really an
- over-approximation of the set of symbols that will not cause an error. And
- there seems to be no way of performing an exact computation, as we would
- need to know not only the current state, but the contents of the stack as
- well. *)
-
-let acceptable_tokens (s : node) =
-
- (* If this state is willing to act on the error token, ignore it -- we do
- not wish to report that an error would be accepted in this state :-) *)
-
- let transitions =
- SymbolMap.remove (Symbol.T Terminal.error) (transitions s)
- and reductions =
- TerminalMap.remove Terminal.error (reductions s)
- in
-
- (* Accumulate the tokens carried by outgoing transitions. *)
-
- let covered =
- SymbolMap.fold (fun symbol _ covered ->
- match symbol with
- | Symbol.T tok ->
- TerminalSet.add tok covered
- | Symbol.N _ ->
- covered
- ) transitions TerminalSet.empty
- in
-
- (* Accumulate the tokens that permit reduction. *)
-
- let covered =
- ProductionMap.fold (fun _ toks covered ->
- TerminalSet.union toks covered
- ) (invert reductions) covered
- in
-
- (* That's it. *)
-
- covered
-
-(* ------------------------------------------------------------------------ *)
-(* Report statistics. *)
-
-(* Produce the reports. *)
-
-let () =
- if !shift_reduce = 1 then
- Error.grammar_warning [] "one state has shift/reduce conflicts."
- else if !shift_reduce > 1 then
- Error.grammar_warning [] (Printf.sprintf "%d states have shift/reduce conflicts." !shift_reduce);
- if !reduce_reduce = 1 then
- Error.grammar_warning [] "one state has reduce/reduce conflicts."
- else if !reduce_reduce > 1 then
- Error.grammar_warning [] (Printf.sprintf "%d states have reduce/reduce conflicts." !reduce_reduce)
-
-(* There is a global check for errors at the end of [Invariant], so we do
- not need to check & stop here. *)
-
-(* ------------------------------------------------------------------------ *)
-(* When requested by the code generator, apply default conflict
- resolution to ensure that the automaton is deterministic. *)
-
-(* [best prod prods] chooses which production should be reduced
- among the list [prod :: prods]. It fails if no best choice
- exists. *)
-
-let rec best choice = function
- | [] ->
- choice
- | prod :: prods ->
- match Precedence.reduce_reduce choice prod with
- | Some choice ->
- best choice prods
- | None ->
- Error.signal
- (Production.positions choice @ Production.positions prod)
- (Printf.sprintf
- "will not resolve reduce/reduce conflict between\n\
- productions that originate in distinct source files:\n%s\n%s"
- (Production.print choice)
- (Production.print prod));
- choice (* dummy *)
-
-(* Go ahead. *)
-
-let default_conflict_resolution () =
-
- let shift_reduce =
- ref 0
- and reduce_reduce =
- ref 0
- in
-
- List.iter (fun node ->
-
- node.reductions <-
- TerminalMap.fold (fun tok prods reductions ->
- try
- let (_ : node) =
- SymbolMap.find (Symbol.T tok) node.transitions
- in
- (* There is a transition at this symbol, so this
- is a (possibly multiway) shift/reduce conflict.
- Resolve in favor of shifting by suppressing all
- reductions. *)
- shift_reduce := List.length prods + !shift_reduce;
- reductions
- with Not_found ->
- (* There is no transition at this symbol. Check
- whether we have multiple reductions. *)
- match prods with
- | [] ->
- assert false
- | [ _ ] ->
- TerminalMap.add tok prods reductions
- | prod :: ((_ :: _) as prods) ->
- (* We have a reduce/reduce conflict. Resolve, if
- possible, in favor of a single reduction.
- This reduction must be preferrable to each
- of the others. *)
- reduce_reduce := List.length prods + !reduce_reduce;
- TerminalMap.add tok [ best prod prods ] reductions
-
- ) node.reductions TerminalMap.empty
-
- ) conflict_nodes;
-
- if !shift_reduce = 1 then
- Error.warning [] "one shift/reduce conflict was arbitrarily resolved."
- else if !shift_reduce > 1 then
- Error.warning [] (Printf.sprintf "%d shift/reduce conflicts were arbitrarily resolved." !shift_reduce);
- if !reduce_reduce = 1 then
- Error.warning [] "one reduce/reduce conflict was arbitrarily resolved."
- else if !reduce_reduce > 1 then
- Error.warning [] (Printf.sprintf "%d reduce/reduce conflicts were arbitrarily resolved." !reduce_reduce);
-
- (* Now, ensure that states that have a reduce action at the
- pseudo-token "#" have no other action. *)
-
- let ambiguities =
- ref 0
- in
-
- fold (fun () node ->
-
- try
- let prods, reductions = TerminalMap.lookup_and_remove Terminal.sharp node.reductions in
- let prod = Misc.single prods in
-
- (* This node has a reduce action at "#". Determine whether there
- exist other actions. If there exist any other actions,
- suppress this reduce action, and signal an ambiguity.
-
- We signal an ambiguity even in the case where all actions at
- this node call for reducing a single production. Indeed, in
- that case, even though we know that this production must be
- reduced, we do not know whether we should first discard the
- current token (and call the lexer). *)
-
- let has_ambiguity = ref false in
- let toks = ref TerminalSet.empty in
-
- TerminalMap.iter (fun tok prods ->
- node.reductions <- reductions;
- has_ambiguity := true;
- toks := TerminalSet.add tok !toks
- ) reductions;
-
- SymbolMap.iter (fun symbol _ ->
- match symbol with
- | Symbol.N _ ->
- ()
- | Symbol.T tok ->
- node.reductions <- reductions;
- has_ambiguity := true;
- toks := TerminalSet.add tok !toks
- ) node.transitions;
-
- if !has_ambiguity then begin
- incr ambiguities;
- if Settings.dump then begin
- Printf.fprintf (Lazy.force out)
- "State %d has an end-of-stream conflict. There is a tension between\n\
- (1) %s\n\
- without even requesting a lookahead token, and\n\
- (2) checking whether the lookahead token is %s%s,\n\
- which would require some other action.\n\n"
- (number node)
- (match Production.classify prod with
- | Some nt ->
- Printf.sprintf "accepting %s" (Nonterminal.print false nt)
- | None ->
- Printf.sprintf "reducing production %s" (Production.print prod))
- (if TerminalSet.cardinal !toks > 1 then "one of " else "")
- (TerminalSet.print !toks)
- end
- end
-
- with Not_found ->
- ()
-
- ) ();
-
- if !ambiguities = 1 then
- Error.grammar_warning [] "one state has an end-of-stream conflict."
- else if !ambiguities > 1 then
- Error.grammar_warning [] (Printf.sprintf "%d states have an end-of-stream conflict." !ambiguities)
-
HCoop / bpt / coccinelle.git / blobdiff