Replaced the command line switch --on-error-reduce with a declaration %on_error_reduce.

TODO

+* A %type declaration with parameters is not properly checked;
+  it could be useless or even ill-typed.
+  Same for %on_error_reduce.
+
 * 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/fancy-parser.mly

@@ -20,7 +20,7 @@ open Positions
 /* Tokens. */
 
 %token TOKEN TYPE LEFT RIGHT NONASSOC START PREC PUBLIC COLON BAR EOF EQUAL
-%token INLINE LPAREN RPAREN COMMA QUESTION STAR PLUS PARAMETER
+%token INLINE LPAREN RPAREN COMMA QUESTION STAR PLUS PARAMETER ON_ERROR_REDUCE
 %token <string Positions.located> LID UID 
 %token <Stretch.t> HEADER
 %token <Stretch.ocamltype> OCAMLTYPE
@@ -96,6 +96,10 @@ declaration:
 | PARAMETER t = OCAMLTYPE
     { [ with_poss $startpos $endpos (DParameter t) ] }
 
+| ON_ERROR_REDUCE ss = clist(strict_actual)
+    { List.map (Positions.map (fun nt -> DOnErrorReduce nt))
+        (List.map Parameters.with_pos ss) }
+
 /* This production recognizes tokens that are valid in the rules section,
    but not in the declarations section. This is a hint that a %% was
    forgotten. */

src/grammar.ml

@@ -1559,3 +1559,13 @@ let diagnostics () =
   TokPrecedence.diagnostics();
   Production.diagnostics()
 
+(* ------------------------------------------------------------------------ *)
+(* %on_error_reduce declarations. *)
+
+module OnErrorReduce = struct
+
+  let declarations =
+    Front.grammar.on_error_reduce
+
+end
+

src/grammar.mli

@@ -497,6 +497,16 @@ module Precedence : sig
 
 end
 
+(* ------------------------------------------------------------------------ *)
+(* %on_error_reduce declarations. *)
+
+module OnErrorReduce : sig
+
+  (* This is the set of %on_error_reduce declarations. *)
+  val declarations: StringSet.t
+
+end
+
 (* ------------------------------------------------------------------------ *)
 (* Diagnostics. *)
 

src/internalSyntax.mli

@@ -7,4 +7,5 @@ type grammar =
       p_types              : (Syntax.parameter * Stretch.ocamltype Positions.located) list;
       p_tokens	           : Syntax.token_properties StringMap.t;
       p_rules	           : Syntax.parameterized_rule StringMap.t;
+      p_on_error_reduce    : Syntax.parameter list;
     }

src/lexer.mll

@@ -305,6 +305,8 @@ rule main = parse
     { PARAMETER }
 | "%inline"
     { INLINE }
+| "%on_error_reduce"
+    { ON_ERROR_REDUCE }
 | "%%"
     { (* The token [PERCENTPERCENT] carries a stretch that contains
          everything that follows %% in the input file. This string

src/lr1.ml

@@ -1058,7 +1058,7 @@ let default_conflict_resolution () =
 (* Extra reductions. 2015/10/19 *)
 
 (* If a state can reduce one production whose left-hand symbol has been marked
-   [--on-error-reduce], and only one such production, then every error action
+   [%on_error_reduce], and only one such production, 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. *)
@@ -1066,7 +1066,7 @@ let default_conflict_resolution () =
 (* The above is the lax interpretation of the criterion. In a stricter
    interpretation, one could require the state to be able to reduce only
    one production, and furthermore require this production to be marked.
-   In practice, the lax interpretation makes [--on-error-reduce] more
+   In practice, the lax interpretation makes [%on_error_reduce] more
    powerful, and this extra power seems useful. *)
 
 (* The code below looks like the decision on a default reduction in
@@ -1099,9 +1099,9 @@ let extra_reductions () =
 
       (* Compute the productions which this node can reduce. *)
       let productions = invert (reductions node) in
-      (* Keep only those whose left-hand symbol is marked [--on-error-reduce]. *)
+      (* Keep only those whose left-hand symbol is marked [%on_error_reduce]. *)
       let productions = ProductionMap.filter (fun prod _ ->
-        StringSet.mem (lhs prod) Settings.on_error_reduce
+        StringSet.mem (lhs prod) OnErrorReduce.declarations
       ) productions in
       (* Check if this only one such production remains. *)
       match ProductionMap.is_singleton productions with
@@ -1130,12 +1130,12 @@ let extra_reductions () =
     Error.logA 1 (fun f ->
       Printf.fprintf f "Extra reductions on error were added in %d states.\n" !extra
     );
-  (* Warning about useless --on-error-reduce switches. *)
+  (* Warn about useless %on_error_reduce declarations. *)
   StringSet.iter (fun nt ->
     if not (StringSet.mem nt !extra_nts) then
       Error.grammar_warning []
-        (Printf.sprintf "the command line option --on-error-reduce %s is never useful." nt)
-  ) Settings.on_error_reduce
+        (Printf.sprintf "the declaration %%on_error_reduce %s is never useful." nt)
+  ) OnErrorReduce.declarations
 
 (* ------------------------------------------------------------------------ *)
 (* Define [fold_entry], which in some cases facilitates the use of [entry]. *)

src/lr1.mli

@@ -143,13 +143,13 @@ 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]. *)
+   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
+   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. *)

src/parameterizedGrammar.ml

@@ -589,7 +589,12 @@ let expand p_grammar =
 	 Expansion is not needed. *)
       with Not_found -> Positions.value sym 
   in
-  let rec types_from_list = function
+
+  (* Process %type declarations. *)
+  let rec types_from_list
+      (ps : (Syntax.parameter * 'a Positions.located) list)
+    : 'a StringMap.t =
+    match ps with
     | [] -> StringMap.empty
     | (nt, ty)::q ->
         let accu = types_from_list q in
@@ -597,11 +602,27 @@ let expand p_grammar =
         if StringMap.mem mangled accu then
           Error.error [Positions.position (Parameters.with_pos nt)]
             (Printf.sprintf
-               "There are multiple %%type definitions for nonterminal %s."
+               "There are multiple %%type declarations for nonterminal %s."
                mangled);
         StringMap.add mangled (Positions.value ty) accu
   in
 
+  (* Process %on_error_reduce declarations. *)
+  let rec on_error_reduce_from_list (ps : Syntax.parameter list) : StringSet.t =
+    match ps with
+    | [] ->
+        StringSet.empty
+    | nt :: ps ->
+        let accu = on_error_reduce_from_list ps in
+        let mangled = mangle nt in
+        if StringSet.mem mangled accu then
+          Error.error [Positions.position (Parameters.with_pos nt)]
+            (Printf.sprintf
+               "There are multiple %%on_error_reduce declarations for nonterminal %s."
+               mangled);
+        StringSet.add mangled accu
+  in
+
   let start_symbols = StringMap.domain (p_grammar.p_start_symbols) in
   {
     preludes      = p_grammar.p_preludes;
@@ -609,6 +630,7 @@ let expand p_grammar =
     parameters    = p_grammar.p_parameters;
     start_symbols = start_symbols;
     types         = types_from_list p_grammar.p_types;
+    on_error_reduce = on_error_reduce_from_list p_grammar.p_on_error_reduce;
     tokens	  = p_grammar.p_tokens;
     rules	  = 
       let closed_rules = StringMap.fold 

src/parserMessages.messages

@@ -20,12 +20,19 @@ grammar: TYPE OCAMLTYPE UID COMMA TYPE
 grammar: TYPE OCAMLTYPE UID LPAREN UID UID 
 grammar: TYPE OCAMLTYPE UID LPAREN UID COMMA TYPE 
 grammar: TYPE OCAMLTYPE UID PLUS RPAREN 
+grammar: ON_ERROR_REDUCE TYPE
 
-Ill-formed %type declaration.
+# %type<ocamltype> and %on_error_reduce are both followed with clist(strict_actual),
+# so they are not distinguished in the automaton.
+
+Ill-formed declaration.
 Examples of well-formed declarations:
   %type <Syntax.expression> expression
   %type <int> date time
   %type <int option> option(date)
+  %on_error_reduce expression
+  %on_error_reduce date time
+  %on_error_reduce option(date)
 
 # ----------------------------------------------------------------------------
 

src/partialGrammar.ml

@@ -84,6 +84,12 @@ let join_declaration filename (grammar : grammar) decl =
       { grammar with
           p_types = (nonterminal, with_pos (position decl) ocamltype)::grammar.p_types }
 
+  (* Reductions on error for nonterminals. *)
+
+  | DOnErrorReduce (nonterminal) ->
+      { grammar with
+        p_on_error_reduce = nonterminal :: grammar.p_on_error_reduce }
+
   (* Token associativity and precedence. *)
 
   | DTokenProperties (terminal, assoc, prec) ->
@@ -571,7 +577,8 @@ let empty_grammar =
     p_start_symbols           = StringMap.empty;
     p_types                   = [];
     p_tokens                  = StringMap.empty;
-    p_rules                   = StringMap.empty
+    p_rules                   = StringMap.empty;
+    p_on_error_reduce         = [];
   }
 
 let join grammar pgrammar =
@@ -618,14 +625,22 @@ let check_parameterized_grammar_is_well_defined grammar =
     | ParameterApp (id, _) -> id
   in
 
-  List.iter (fun (symbol, _) ->
-    let head_symb = parameter_head_symb symbol in
-    if not (StringMap.mem (value head_symb) grammar.p_rules) then
-      Error.errorp (Parameters.with_pos symbol)
-	(Printf.sprintf
-	   "this is a terminal symbol.\n\
-             %%type declarations are applicable only to nonterminal symbols."))
-    grammar.p_types;
+  (* Every %type definition has, at its head, a nonterminal symbol. *)
+  (* Same check for %on_error_reduce definitions. *)
+  (* Apparently we do not check the parameters at this point. Maybe this is
+     done later, or not at all. *)
+  let check (kind : string) (ps : Syntax.parameter list) =
+    List.iter (fun p ->
+      let head_symb = parameter_head_symb p in
+      if not (StringMap.mem (value head_symb) grammar.p_rules) then
+        Error.errorp (Parameters.with_pos p)
+          (Printf.sprintf
+             "this should be a nonterminal symbol.\n\
+              %s declarations are applicable only to nonterminal symbols." kind)
+    ) ps
+  in
+  check "%type" (List.map fst grammar.p_types);
+  check "%on_error_reduce" grammar.p_on_error_reduce;
 
   (* Every reference to a symbol is well defined. *)
   let reserved = [ "error" ] in

src/settings.ml

@@ -197,12 +197,6 @@ let echo_errors =
 let set_echo_errors filename =
   echo_errors := Some filename
 
-let on_error_reduce =
-  ref StringSet.empty
-
-let on_error_reduce_symbol nt =
-  on_error_reduce := StringSet.add nt !on_error_reduce
-
 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";
@@ -238,7 +232,6 @@ 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),
@@ -475,6 +468,3 @@ let update_errors =
 let echo_errors =
   !echo_errors
 
-let on_error_reduce =
-  !on_error_reduce
-

src/settings.mli

@@ -208,9 +208,3 @@ val update_errors: string option
 
 val echo_errors: string option
 
-(* This is the set of non-terminal symbols that appear 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: StringSet.t
-

src/syntax.mli

@@ -85,6 +85,10 @@ type declaration =
 
   | DType of Stretch.ocamltype * parameter
 
+    (* On-error-reduce declaration. *)
+
+  | DOnErrorReduce of parameter
+
 (* A [%prec] annotation is optional. A production can carry at most one.
    If there is one, it is a symbol name. See [ParserAux]. *)
 

src/unparameterizedSyntax.ml

@@ -40,6 +40,7 @@ type grammar =
       parameters           : Stretch.t list;
       start_symbols        : StringSet.t;
       types                : Stretch.ocamltype StringMap.t;
+      on_error_reduce      : StringSet.t;
       tokens	           : Syntax.token_properties StringMap.t;
       rules	           : rule StringMap.t;
     }

src/yacc-parser.mly

@@ -14,7 +14,7 @@ open Positions
 %}
 
 %token TOKEN TYPE LEFT RIGHT NONASSOC START PREC PUBLIC COLON BAR EOF EQUAL 
-%token INLINE LPAREN RPAREN COMMA QUESTION STAR PLUS PARAMETER
+%token INLINE LPAREN RPAREN COMMA QUESTION STAR PLUS PARAMETER ON_ERROR_REDUCE
 %token <string Positions.located> LID UID 
 %token <Stretch.t> HEADER
 %token <Stretch.ocamltype> OCAMLTYPE
@@ -92,6 +92,10 @@ declaration:
 | PARAMETER OCAMLTYPE
     { [ unknown_pos (DParameter $2) ] }
 
+| ON_ERROR_REDUCE actuals
+    { List.map (Positions.map (fun nt -> DOnErrorReduce nt))
+        (List.map Parameters.with_pos $2) }
+
 optional_ocamltype:
   /* epsilon */
     { None }