Added an experimental switch, [--on-error-reduce symbol].

TODO

+* If we keep --on-error-reduce, document it.
+
 * Is it true that the warning "this production is never reduced" is
   sound but incomplete? i.e. certain states could be unreachable and
   we do not know it (but LRijkstra can tell us).

src/conflict.ml

@@ -506,3 +506,9 @@ let () =
   Lr1.default_conflict_resolution();
   Time.tick "Resolving remaining conflicts"
 
+(* This is a good place to add extra reductions, if requested by the user. *)
+
+let () =
+  Lr1.extra_reductions();
+  Time.tick "Adding extra reductions"
+

src/lr1.ml

@@ -1057,6 +1057,60 @@ let default_conflict_resolution () =
   else if !ambiguities > 1 then
     Error.grammar_warning [] (Printf.sprintf "%d states have an end-of-stream conflict." !ambiguities)
 
+(* ------------------------------------------------------------------------ *)
+(* Extra reductions. 2015/10/19 *)
+
+(* If a state can reduce only one production, whose left-hand symbol has
+   been declared [--on-error-reduce], then every error action in this
+   state is replaced with a reduction action. This is done even though
+   this state may have outgoing shift transitions: thus, we are forcing
+   one interpretation of the past, among several possible interpretations. *)
+
+(* This code looks like the decision for a default reduction in [Invariant],
+   except we do not impose the absence of outgoing terminal transitions.
+   Also, we actually modify the automaton, so the back-ends, the reference
+   interpreter, etc. need not be aware of this feature, whereas they are
+   aware of default reductions. *)
+
+let extra =
+  ref 0
+
+let extra_reductions () =
+  iter (fun node ->
+    if not node.forbid_default_reduction then
+      match ProductionMap.is_singleton (invert (reductions node)) with
+      | Some (prod, toks)
+        when Settings.on_error_reduce (Nonterminal.print false (Production.nt prod)) ->
+          (* An extra reduction is possible. Take the set of all (real) tokens,
+             subtract the tokens for which there is an outgoing transition,
+             and allow reduction of [prod] on all of the remaining tokens. *)
+          let accu =
+            SymbolMap.fold (fun symbol _target accu ->
+              match symbol with
+              | Symbol.T tok ->
+                  TerminalSet.remove tok accu
+              | Symbol.N _ ->
+                  accu
+            ) (transitions node) TerminalSet.universe
+          in
+          (* Since shift/reduce conflicts have been resolved already, we
+             should have this property: *)
+          assert (TerminalSet.subset toks accu);
+          (* Allow reduction of [prod] on the tokens in [accu]. *)
+          TerminalSet.iter (fun tok ->
+            node.reductions <- TerminalMap.add tok [ prod ] node.reductions
+          ) accu;
+          (* Statistics. *)
+          if not (TerminalSet.subset accu toks) then
+            incr extra;
+      | _ ->
+          ()
+  );
+  if !extra > 0 then
+    Error.logA 1 (fun f ->
+      Printf.fprintf f "Extra reductions on error were added in %d states.\n" !extra
+    )
+
 (* ------------------------------------------------------------------------ *)
 (* Define [fold_entry], which in some cases facilitates the use of [entry]. *)
 

src/lr1.mli

@@ -142,3 +142,17 @@ val reverse_dfs: node -> (node -> bool)
 
 val default_conflict_resolution: unit -> unit
 
+(* This function adds extra reduction actions in the face of an error, if
+   requested by the user via [--on-error-reduce]. *)
+
+(* It must be called after conflict resolution has taken place. The
+   automaton is modified in place. *)
+
+(* If a state can reduce only one production, whose left-hand symbol has
+   been declared [--on-error-reduce], then every error action in this
+   state is replaced with a reduction action. This is done even though
+   this state may have outgoing shift transitions: thus, we are forcing
+   one interpretation of the past, among several possible interpretations. *)
+
+val extra_reductions: unit -> unit
+

src/settings.ml

@@ -191,6 +191,12 @@ let update_errors =
 let set_update_errors filename =
   update_errors := Some filename
 
+let on_error_reduce_symbols =
+  ref StringSet.empty
+
+let on_error_reduce_symbol nt =
+  on_error_reduce_symbols := StringSet.add nt !on_error_reduce_symbols
+
 let options = Arg.align [
   "--base", Arg.Set_string base, "<basename> Specifies a base name for the output file(s)";
   "--canonical", Arg.Unit (fun () -> construction_mode := ModeCanonical), " Construct a canonical Knuth LR(1) automaton";
@@ -225,6 +231,7 @@ let options = Arg.align [
   "--no-stdlib", Arg.Set no_stdlib, " Do not load the standard library";
   "--ocamlc", Arg.Set_string ocamlc, "<command> Specifies how ocamlc should be invoked";
   "--ocamldep", Arg.Set_string ocamldep, "<command> Specifies how ocamldep should be invoked";
+  "--on-error-reduce", Arg.String on_error_reduce_symbol, "<symbol> Reduce this nonterminal symbol upon an error";
   "--only-preprocess", Arg.Unit (fun () -> preprocess_mode := PMOnlyPreprocess PrintNormal),
                        " Print grammar and exit";
   "--only-preprocess-u", Arg.Unit (fun () -> preprocess_mode := PMOnlyPreprocess PrintUnitActions),
@@ -458,3 +465,6 @@ let compare_errors =
 let update_errors =
   !update_errors
 
+let on_error_reduce nt =
+  StringSet.mem nt !on_error_reduce_symbols
+

src/settings.mli

@@ -202,3 +202,9 @@ val compare_errors: (string * string) option
 
 val update_errors: string option
 
+(* This function takes a non-terminal symbol and tells whether it appears
+   in a command line switch of the form [--on-error-reduce]. This switch
+   indicates that extra reductions are desired when an error is detected. *)
+
+val on_error_reduce: string -> bool
+