diff -Nru menhir-20160526.dfsg/CHANGES menhir-20160808+dfsg/CHANGES --- menhir-20160526.dfsg/CHANGES 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/CHANGES 2016-08-08 19:19:04.000000000 +0000 @@ -1,3 +1,16 @@ +2016/08/05: +%on_error_reduce declarations now have implicit priority levels, so as to +tell Menhir what to do when two such declarations are applicable. +Also, the well-formedness checks on %type and %on_error_reduce declarations +have been reinforced. + +2016/06/23: +A small change in the generated code (both in the code and table back-ends) so +as to avoid OCaml's warning 41. The warning would arise (when compiling a +generated parser with OCaml 4.03) because Menhir's exception [Error] has the +same name as the data constructor [Error] in OCaml's pervasive library. +(Reported by Bernhard Schommer.) + 2016/05/18: Anonymous rules now work also when used inside a parameterized rule. (This did not work until now.) When an anonymous rule is hoisted out diff -Nru menhir-20160526.dfsg/debian/changelog menhir-20160808+dfsg/debian/changelog --- menhir-20160526.dfsg/debian/changelog 2016-08-06 08:55:33.000000000 +0000 +++ menhir-20160808+dfsg/debian/changelog 2016-08-16 08:06:20.000000000 +0000 @@ -1,3 +1,10 @@ +menhir (20160808+dfsg-1) unstable; urgency=medium + + * Team upload + * New upstream release + + -- Stéphane Glondu Tue, 16 Aug 2016 10:06:20 +0200 + menhir (20160526.dfsg-1) unstable; urgency=medium * Team upload diff -Nru menhir-20160526.dfsg/debian/watch menhir-20160808+dfsg/debian/watch --- menhir-20160526.dfsg/debian/watch 2016-08-06 08:23:48.000000000 +0000 +++ menhir-20160808+dfsg/debian/watch 2016-08-16 08:05:35.000000000 +0000 @@ -1,4 +1,4 @@ version=3 -opts=dversionmangle=s/\.dfsg// \ +opts=dversionmangle=s/\+dfsg// \ http://pauillac.inria.fr/~fpottier/menhir/menhir-(.*)\.tar\.gz diff -Nru menhir-20160526.dfsg/INSTALLATION menhir-20160808+dfsg/INSTALLATION --- menhir-20160526.dfsg/INSTALLATION 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/INSTALLATION 2016-08-08 19:19:04.000000000 +0000 @@ -1,39 +1,46 @@ +------------------------------------------------------------------------------ + REQUIREMENTS You need Objective Caml 4.02 or later, ocamlbuild, and GNU make. -HOW TO INSTALL - -If you wish to install via ocamlfind, make sure that ocamlfind is in -your PATH. (Remember that prefixing a command with sudo affects its -PATH.) - -Run the following commands: +------------------------------------------------------------------------------ - make PREFIX=/usr/local all - make PREFIX=/usr/local install +CONFIGURATION CHOICES -If your machine does not have the native code Objective Caml compiler -(ocamlopt), but does have the bytecode compiler (ocamlc), then instead -of the above command, use: - - make PREFIX=/usr/local TARGET=byte all - make PREFIX=/usr/local TARGET=byte install +1- PREFIX -The value of the PREFIX variable can be changed to control where -the software, the standard library, and the documentation should -be stored. These files are copied to the following places: +The value of the PREFIX variable can be changed to control where the software, +the standard library, and the documentation are stored. These files are copied +to the following places: $PREFIX/bin/ $PREFIX/share/menhir/ $PREFIX/doc/menhir/ -The support library, MenhirLib, is either installed via ocamlfind or placed -within $PREFIX/share/menhir. By default, ocamlfind is used if it is found in -the PATH. This decision may be overridden by setting USE_OCAMLFIND to either -true or false when running "make all". +PREFIX must be set when invoking "make all" and "make install" (see below). + +2- USE_OCAMLFIND + +The support library, MenhirLib, is either installed via ocamlfind or installed +directly in the directory $PREFIX/share/menhir. Installing via ocamlfind is +recommended (and is the default). It requires the "ocamlfind" executable to be +found in the PATH. An explicit choice can be made by setting USE_OCAMLFIND to +"true" or "false" when running "make all" (see below). + +3- TARGET + +If your machine does not have the native code Objective Caml compiler +(ocamlopt), but does have the bytecode compiler (ocamlc), then you +should define "TARGET=byte" when running "make all" and "make install". + +------------------------------------------------------------------------------ + +COMPILATION & INSTALLATION -Menhir's --suggest options help determine where and how MenhirLib was installed. +Compile and install as follows: -The documentation includes a reference manual and a number of demos. + make PREFIX=/usr/local USE_OCAMLFIND=true all + sudo make PREFIX=/usr/local install +(If necessary, adjust PREFIX, USE_OCAMLFIND and TARGET as described above.) diff -Nru menhir-20160526.dfsg/Makefile menhir-20160808+dfsg/Makefile --- menhir-20160526.dfsg/Makefile 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/Makefile 2016-08-08 19:19:04.000000000 +0000 @@ -170,23 +170,22 @@ mkdir -p $(libdir) install -m 644 $(MLYLIB) $(libdir) @if `$(BUILDDIR)/menhir.$(TARGET) --suggest-ocamlfind` ; then \ - echo Installing MenhirLib via ocamlfind. ; \ + echo 'Installing MenhirLib via ocamlfind.' ; \ ocamlfind install menhirLib src/META $(patsubst %,$(BUILDDIR)/%,$(MENHIRLIB)) ; \ else \ - echo Installing MenhirLib manually. ; \ + echo 'Installing MenhirLib manually.' ; \ install -m 644 $(patsubst %,$(BUILDDIR)/%,$(MENHIRLIB)) $(libdir) ; \ fi # Install the documentation, if it has been built. if [ -f manual.pdf ] ; then \ - mkdir -p $(docdir) ; \ - mkdir -p $(mandir) ; \ - cp -r $(DOCS) $(docdir) ; \ + mkdir -p $(docdir) $(mandir) && \ + cp -r $(DOCS) $(docdir) && \ cp -r $(MANS) $(mandir) ; \ fi uninstall: @if `$(bindir)/$(MENHIREXE) --suggest-ocamlfind` ; then \ - echo Un-installing MenhirLib via ocamlfind. ; \ + echo 'Un-installing MenhirLib via ocamlfind.' ; \ ocamlfind remove menhirLib ; \ fi rm -rf $(bindir)/$(MENHIREXE) diff -Nru menhir-20160526.dfsg/src/codeBackend.ml menhir-20160808+dfsg/src/codeBackend.ml --- menhir-20160526.dfsg/src/codeBackend.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/codeBackend.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1636,13 +1636,7 @@ [ SIFunctor (grammar.parameters, - SIExcDefs [ excdef ] :: - - SIValDefs (false, [ excvaldef ]) :: - - interface_to_structure ( - tokentypedef grammar - ) @ + mbasics grammar @ SITypeDefs [ envtypedef; statetypedef ] :: @@ -1687,4 +1681,3 @@ Time.tick "Producing abstract syntax" end - diff -Nru menhir-20160526.dfsg/src/codePieces.ml menhir-20160808+dfsg/src/codePieces.ml --- menhir-20160526.dfsg/src/codePieces.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/codePieces.ml 2016-08-08 19:19:04.000000000 +0000 @@ -209,9 +209,34 @@ let errorval = EVar parse_error +let basics = + "Basics" + let excvaldef = { valpublic = false; valpat = PVar parse_error; - valval = EData (Interface.excname, []) + valval = EData (basics ^ "." ^ Interface.excname, []) + (* 2016/06/23 We now use the qualified name [Basics.Error], instead of + just [Error], so as to avoid OCaml's warning 41. *) } +(* ------------------------------------------------------------------------ *) + +(* Define the internal sub-module [Basics], which contains the definitions + of the exception [Error] and of the type [token]. Then, include this + sub-module. This is used both in the code and table back-ends. *) + +let mbasics grammar = [ + + SIModuleDef (basics, MStruct ( + SIExcDefs [ Interface.excdef ] :: + interface_to_structure ( + TokenType.tokentypedef grammar + ) + )); + + SIInclude (MVar basics); + + SIValDefs (false, [ excvaldef ]); + +] diff -Nru menhir-20160526.dfsg/src/codePieces.mli menhir-20160808+dfsg/src/codePieces.mli --- menhir-20160526.dfsg/src/codePieces.mli 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/codePieces.mli 2016-08-08 19:19:04.000000000 +0000 @@ -109,11 +109,17 @@ (* A global variable holds the exception [Error]. *) -(* The definition of this global variable. *) - -val excvaldef: valdef - (* A reference to this global variable. *) val errorval: expr +(* ------------------------------------------------------------------------ *) + +(* The structure items [mbasics grammar] define and include the internal + sub-module [Basics], which contains the definitions of the exception + [Error] and of the type [token]. Then, they define the global variable + mentioned above, which holds the exception [Error]. *) + +val basics: string + +val mbasics: UnparameterizedSyntax.grammar -> structure diff -Nru menhir-20160526.dfsg/src/fancy-parser.mly menhir-20160808+dfsg/src/fancy-parser.mly --- menhir-20160526.dfsg/src/fancy-parser.mly 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/fancy-parser.mly 2016-08-08 19:19:04.000000000 +0000 @@ -96,7 +96,8 @@ { [ with_poss $startpos $endpos (DParameter t) ] } | ON_ERROR_REDUCE ss = clist(strict_actual) - { List.map (Positions.map (fun nt -> DOnErrorReduce nt)) + { let prec = ParserAux.new_on_error_reduce_level() in + List.map (Positions.map (fun nt -> DOnErrorReduce (nt, prec))) (List.map Parameters.with_pos ss) } /* This production recognizes tokens that are valid in the rules section, diff -Nru menhir-20160526.dfsg/src/grammarFunctor.ml menhir-20160808+dfsg/src/grammarFunctor.ml --- menhir-20160526.dfsg/src/grammarFunctor.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/grammarFunctor.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1464,12 +1464,69 @@ module OnErrorReduce = struct - let declarations = + (* We keep a [StringMap] internally, and convert back and forth between + the types [Nonterminal.t] and [string] when querying this map. This + is not very elegant, and could be changed if desired. *) + + let declarations : Syntax.on_error_reduce_level StringMap.t = grammar.on_error_reduce + let print (nt : Nonterminal.t) : string = + Nonterminal.print false nt + + let lookup (nt : string) : Nonterminal.t = + try + Nonterminal.lookup nt + with Not_found -> + (* If this fails, then we have an [%on_error_reduce] declaration + for an invalid symbol. *) + assert false + + let reduce prod = + let nt = Production.nt prod in + StringMap.mem (print nt) declarations + + let iter f = + StringMap.iter (fun nt _prec -> + f (lookup nt) + ) declarations + + open Precedence + + let preferable prod1 prod2 = + (* The two productions that we are comparing must be distinct. *) + assert (prod1 <> prod2); + let nt1 = Production.nt prod1 + and nt2 = Production.nt prod2 in + (* If they have the same left-hand side (which seems rather unlikely?), + declare them incomparable. *) + nt1 <> nt2 && + (* Otherwise, look up the priority levels associated with their left-hand + symbols. *) + let prec1, prec2 = + try + StringMap.find (print nt1) declarations, + StringMap.find (print nt2) declarations + with Not_found -> + (* [preferable] should be used to compare two symbols for which + there exist [%on_error_reduce] declarations. *) + assert false + in + match production_order prec1 prec2 with + | Gt -> + (* [prec1] is a higher integer than [prec2], therefore comes later + in the file. By analogy with [%left] and friends, we give higher + priority to later declarations. *) + true + | Lt -> + false + | Eq + | Ic -> + (* We could issue a warning or an information message in these cases. *) + false + end (* ------------------------------------------------------------------------ *) end (* module Make *) - diff -Nru menhir-20160526.dfsg/src/grammarFunctor.mli menhir-20160808+dfsg/src/grammarFunctor.mli --- menhir-20160526.dfsg/src/grammarFunctor.mli 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/grammarFunctor.mli 2016-08-08 19:19:04.000000000 +0000 @@ -515,12 +515,27 @@ end (* ------------------------------------------------------------------------ *) -(* %on_error_reduce declarations. *) +(* [%on_error_reduce] declarations. *) module OnErrorReduce : sig - (* This is the set of %on_error_reduce declarations. *) - val declarations: StringSet.t + (* [reduce prod] tells whether the left-hand side of [prod] (a nonterminal + symbol) appears in an [%on_error_reduce] declaration. *) + + val reduce: Production.index -> bool + + (* [iter f] applies the function [f] in turn, in an arbitrary order, to + every nonterminal symbol that appears in an [%on_error_reduce] + declaration. *) + + val iter: (Nonterminal.t -> unit) -> unit + + (* When two productions could be reduced, in a single state, due to + [%on_error_reduce] declarations, these productions can be compared, using + [preferable], to test if one of them takes precedence over the other. + This is a partial order; two productions may be incomparable. *) + + val preferable: Production.index -> Production.index -> bool end @@ -536,5 +551,3 @@ (* ------------------------------------------------------------------------ *) end (* module Make *) - - diff -Nru menhir-20160526.dfsg/src/lr1.ml menhir-20160808+dfsg/src/lr1.ml --- menhir-20160526.dfsg/src/lr1.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/lr1.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1069,19 +1069,19 @@ Error.grammar_warning [] "%d states have an end-of-stream conflict." !ambiguities (* ------------------------------------------------------------------------ *) -(* Extra reductions. 2015/10/19 *) +(* Extra reductions. *) -(* 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 - 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. *) - -(* 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 - powerful, and this extra power seems useful. *) +(* 2015/10/19 Original implementation. *) +(* 2016/07/13 Use priority levels to choose which productions to reduce + when several productions are eligible. *) + +(* If a state can reduce some productions whose left-hand symbol has been + marked [%on_error_reduce], and if one such production [prod] is preferable + to every other (according to the priority rules of [%on_error_reduce] + declarations), then every error action in this state is replaced with a + reduction of [prod]. 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. *) (* The code below looks like the decision on a default reduction in [Invariant], except we do not impose the absence of outgoing terminal @@ -1097,59 +1097,69 @@ let extra = ref 0 +(* A count of how many states have more than one eligible production, but one + is preferable to every other (so priority plays a role). *) + +let prioritized = + ref 0 + (* The set of nonterminal symbols in the left-hand side of an extra reduction. *) let extra_nts = - ref StringSet.empty + ref NonterminalSet.empty -let lhs prod : string = - Nonterminal.print false (Production.nt prod) +let extra_reductions_in_node node = + (* Compute the productions which this node can reduce. *) + let productions : _ ProductionMap.t = invert (reductions node) in + let prods : Production.index list = + ProductionMap.fold (fun prod _ prods -> prod :: prods) productions [] + in + (* Keep only those whose left-hand symbol is marked [%on_error_reduce]. *) + let prods = List.filter OnErrorReduce.reduce prods in + (* Check if one of them is preferable to every other one. *) + match Misc.best OnErrorReduce.preferable prods with + | None -> + (* Either no production is marked [%on_error_reduce], or several of them + are marked and none is preferable. *) + () + | Some prod -> + let acceptable = acceptable_tokens node in + (* An extra reduction is possible. Replace every error action with + a reduction of [prod]. If we replace at least one error action + with a reduction, update [extra] and [extra_nts]. *) + let triggered = lazy ( + incr extra; + if List.length prods > 1 then incr prioritized; + extra_nts := NonterminalSet.add (Production.nt prod) !extra_nts + ) in + Terminal.iter_real (fun tok -> + if not (TerminalSet.mem tok acceptable) then begin + node.reductions <- TerminalMap.add tok [ prod ] node.reductions; + Lazy.force triggered + end + ) let extra_reductions () = + (* Examine every node. *) iter (fun node -> (* Just like a default reduction, an extra reduction should be forbidden (it seems) if [forbid_default_reduction] is set. *) - if not node.forbid_default_reduction then begin - - (* 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]. *) - let productions = ProductionMap.filter (fun prod _ -> - StringSet.mem (lhs prod) OnErrorReduce.declarations - ) productions in - (* Check if this only one such production remains. *) - match ProductionMap.is_singleton productions with - | None -> - () - | Some (prod, _) -> - let acceptable = acceptable_tokens node in - (* An extra reduction is possible. Replace every error action with - a reduction of [prod]. If we replace at least one error action - with a reduction, update [extra] and [extra_nts]. *) - let triggered = lazy ( - incr extra; - extra_nts := StringSet.add (lhs prod) !extra_nts - ) in - Terminal.iter_real (fun tok -> - if not (TerminalSet.mem tok acceptable) then begin - node.reductions <- TerminalMap.add tok [ prod ] node.reductions; - Lazy.force triggered - end - ) - - end + if not node.forbid_default_reduction then + extra_reductions_in_node node ); (* Info message. *) if !extra > 0 then Error.logA 1 (fun f -> - Printf.fprintf f "Extra reductions on error were added in %d states.\n" !extra + Printf.fprintf f "Extra reductions on error were added in %d states.\n" !extra; + Printf.fprintf f "Priority played a role in %d of these states.\n" !prioritized ); (* Warn about useless %on_error_reduce declarations. *) - StringSet.iter (fun nt -> - if not (StringSet.mem nt !extra_nts) then + OnErrorReduce.iter (fun nt -> + if not (NonterminalSet.mem nt !extra_nts) then Error.grammar_warning [] - "the declaration %%on_error_reduce %s is never useful." nt - ) OnErrorReduce.declarations + "the declaration %%on_error_reduce %s is never useful." + (Nonterminal.print false nt) + ) (* ------------------------------------------------------------------------ *) (* Define [fold_entry], which in some cases facilitates the use of [entry]. *) diff -Nru menhir-20160526.dfsg/src/menhirLib.mlpack menhir-20160808+dfsg/src/menhirLib.mlpack --- menhir-20160526.dfsg/src/menhirLib.mlpack 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/menhirLib.mlpack 2016-08-08 19:19:04.000000000 +0000 @@ -1,5 +1,5 @@ # This is the list of modules that must go into MenhirLib. -# Thy must be listed in dependency order, as this list is +# They must be listed in dependency order, as this list is # used to construct menhirLib.ml at installation time. General Convert diff -Nru menhir-20160526.dfsg/src/META menhir-20160808+dfsg/src/META --- menhir-20160526.dfsg/src/META 2016-05-26 21:50:28.000000000 +0000 +++ menhir-20160808+dfsg/src/META 2016-08-08 19:19:04.000000000 +0000 @@ -2,4 +2,4 @@ description = "Runtime support for code generated by Menhir" archive(byte) = "menhirLib.cmo" archive(native) = "menhirLib.cmx" -version = "20160526" +version = "20160808" diff -Nru menhir-20160526.dfsg/src/misc.ml menhir-20160808+dfsg/src/misc.ml --- menhir-20160526.dfsg/src/misc.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/misc.ml 2016-08-08 19:19:04.000000000 +0000 @@ -317,3 +317,30 @@ in encode, decode, verbose +let rec best (preferable : 'a -> 'a -> bool) (xs : 'a list) : 'a option = + match xs with + | [] -> + (* Special case: no elements at all, so no best element. This case + does not participate in the recursion. *) + None + | [x] -> + Some x + | x :: xs -> + (* If [x] is preferable to every element of [xs], then it is the + best element of [x :: xs]. *) + if List.for_all (preferable x) xs then + Some x + else + (* [xs] is nonempty, so the recursive call is permitted. *) + match best preferable xs with + | Some y -> + if preferable y x then + (* If [y] is the best element of [xs] and [y] is preferable to + [x], then [y] is the best element of [x :: xs]. *) + Some y + else + (* There is no best element. *) + None + | None -> + (* There is no best element. *) + None diff -Nru menhir-20160526.dfsg/src/misc.mli menhir-20160808+dfsg/src/misc.mli --- menhir-20160526.dfsg/src/misc.mli 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/misc.mli 2016-08-08 19:19:04.000000000 +0000 @@ -178,3 +178,8 @@ so far. *) val new_encode_decode: int -> (string -> int) * (int -> string) * (unit -> unit) +(* If [preferable] is a partial order on elements, then [best preferable xs] + returns the best (least) element of [xs], if there is one. Its complexity + is quadratic. *) + +val best: ('a -> 'a -> bool) -> 'a list -> 'a option diff -Nru menhir-20160526.dfsg/src/myocamlbuild.ml menhir-20160808+dfsg/src/myocamlbuild.ml --- menhir-20160526.dfsg/src/myocamlbuild.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/myocamlbuild.ml 2016-08-08 19:19:04.000000000 +0000 @@ -269,9 +269,7 @@ (* Compilation flags for Menhir. *) let flags () = - (* -inline 1000 *) - flag ["ocaml"; "compile"; "native"] (S [A "-inline"; A "1000"]); - (* -noassert *) + (* -noassert (if enabled by tag) *) flag ["ocaml"; "compile"; "noassert"] (S [A "-noassert"]); (* nazi warnings *) flag ["ocaml"; "compile"; "my_warnings"] (S[A "-w"; A "@1..49-4-9-41-44"]) diff -Nru menhir-20160526.dfsg/src/nonTerminalDefinitionInlining.ml menhir-20160808+dfsg/src/nonTerminalDefinitionInlining.ml --- menhir-20160526.dfsg/src/nonTerminalDefinitionInlining.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/nonTerminalDefinitionInlining.ml 2016-08-08 19:19:04.000000000 +0000 @@ -308,19 +308,32 @@ grammar.rules in - (* To expand a grammar, we expand all its rules and remove - the %inline rules. *) + (* To expand a grammar, we expand all its rules and remove + the %inline rules. *) let expanded_rules = StringMap.mapi expand_rule grammar.rules - and useful_types = - StringMap.filter - (fun k _ -> try not (StringMap.find k grammar.rules).inline_flag - with Not_found -> true) - grammar.types in - { grammar with - rules = StringMap.filter (fun _ r -> not r.inline_flag) expanded_rules; - types = useful_types - }, !use_inline + let useful (k : string) : bool = + try + not (StringMap.find k grammar.rules).inline_flag + with Not_found -> + true (* could be: assert false? *) + in + + (* Remove %on_error_reduce declarations for symbols that are expanded away, + and warn about them, at the same time. *) + let useful_warn (k : string) : bool = + let u = useful k in + if not u then + Error.grammar_warning [] + "the declaration %%on_error_reduce %s\n\ + has no effect, since this symbol is marked %%inline and is expanded away." k; + u + in + { grammar with + rules = StringMap.filter (fun _ r -> not r.inline_flag) expanded_rules; + types = StringMap.filter (fun k _ -> useful k) grammar.types; + on_error_reduce = StringMap.filter (fun k _ -> useful_warn k) grammar.on_error_reduce; + }, !use_inline diff -Nru menhir-20160526.dfsg/src/parameterizedGrammar.ml menhir-20160808+dfsg/src/parameterizedGrammar.ml --- menhir-20160526.dfsg/src/parameterizedGrammar.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/parameterizedGrammar.ml 2016-08-08 19:19:04.000000000 +0000 @@ -189,14 +189,16 @@ (* [lookup x env] returns the type related to [x] in the typing environment [env]. By convention, identifiers that are not in [env] are terminals. They are - given the type [Star]. *) -let lookup x (env: environment) = + given the type [Star]. (This seems a rather fragile convention, as it + relies on the fact that the well-definedness of every identifier has + been previously checked; see [PartialGrammar]. -fpottier) *) +let lookup (x : string) (env: environment) = try snd (List.assoc x env) with Not_found -> star_variable (* This function checks that the symbol [k] has the type [expected_type]. *) -let check positions env k expected_type = +let check positions env k expected_type : unit = let inference_var = lookup k env in let checking_var = fresh_structured_variable expected_type in try @@ -252,6 +254,14 @@ (* Anonymous rules are eliminated early on. *) assert false +let check_parameter_type env p : unit = + let symbol, actuals = Parameters.unapp p in + let expected_ty = + if actuals = [] then star + else Arrow (List.map (parameter_type env) actuals) + in + check [ symbol.position ] env symbol.value expected_ty + let check_grammar (p_grammar : Syntax.grammar) = (* [n] is the grammar size. *) let n = StringMap.cardinal p_grammar.p_rules in @@ -363,77 +373,84 @@ p_grammar.p_rules [] in - (* We traverse the graph checking each parameterized non terminal - definition is well-formed. *) - RulesGraph.iter - (fun i -> - let params = parameters i - and iname = name i - and repr = ConnectedComponents.representative i - and positions = positions i - in + (* We traverse the graph checking each parameterized non terminal + definition is well-formed. *) + RulesGraph.iter (fun i -> + let params = parameters i + and iname = name i + and repr = ConnectedComponents.representative i + and positions = positions i + in - (* The environment is augmented with the parameters whose types are - unknown. *) - let env' = List.map - (fun k -> (k, (positions, fresh_flexible_variable ()))) params - in - let env = env' @ env in + (* The environment is augmented with the parameters whose types are + unknown. *) + let env' = List.map + (fun k -> (k, (positions, fresh_flexible_variable ()))) params + in + let env = env' @ env in - (* The type of the parameterized non terminal is constrained to be - [expected_ty]. *) - let check_type () = - check positions env iname (Arrow (List.map (fun (_, (_, t)) -> t) env')) - in + (* The type of the parameterized non terminal is constrained to be + [expected_ty]. *) + let check_type () = + check positions env iname (Arrow (List.map (fun (_, (_, t)) -> t) env')) + in - (* We check the number of parameters. *) - let check_parameters () = - let parameters_len = List.length params in - (* The component is visited for the first time. *) - if marked_components.(repr) = unseen then - marked_components.(repr) <- parameters_len - else (* Otherwise, we check that the arity is homogeneous - in the component. *) - if marked_components.(repr) <> parameters_len then - Error.error positions - "mutually recursive definitions must have the same parameters.\n\ - This is not the case for %s and %s." - (name repr) iname - in + (* We check the number of parameters. *) + let check_parameters () = + let parameters_len = List.length params in + (* The component is visited for the first time. *) + if marked_components.(repr) = unseen then + marked_components.(repr) <- parameters_len + else (* Otherwise, we check that the arity is homogeneous + in the component. *) + if marked_components.(repr) <> parameters_len then + Error.error positions + "mutually recursive definitions must have the same parameters.\n\ + This is not the case for %s and %s." + (name repr) iname + in - (* In each production rule, the parameterized non terminal - of the same component must be instantiated with the same - formal arguments. *) - let check_producers () = - List.iter - (fun { pr_producers = symbols } -> List.iter - (function (_, p) -> - let symbol, actuals = Parameters.unapp p in - (* We take the use of each symbol into account. *) - check [ symbol.position ] env symbol.value - (if actuals = [] then star else - Arrow (List.map (parameter_type env) actuals)); - (* If it is in the same component, check in addition that - the arguments are the formal arguments. *) - try - let idx = conv symbol.value in - if ConnectedComponents.representative idx = repr then - if not (actual_parameters_as_formal actuals params) - then - Error.error [ symbol.position ] - "mutually recursive definitions must have the same \ - parameters.\n\ - This is not the case for %s." - (let name1, name2 = (name idx), (name i) in - if name1 <> name2 then name1 ^ " and "^ name2 - else name1) - with _ -> ()) - symbols) (branches i) - in - check_type (); - check_parameters (); - check_producers ()) + (* In each production rule, the parameterized non terminal + of the same component must be instantiated with the same + formal arguments. *) + let check_producers () = + List.iter + (fun { pr_producers = symbols } -> List.iter + (function (_, p) -> + (* We take the use of each symbol into account. *) + check_parameter_type env p; + (* If it is in the same component, check in addition that + the arguments are the formal arguments. *) + let symbol, actuals = Parameters.unapp p in + try + let idx = conv symbol.value in + if ConnectedComponents.representative idx = repr then + if not (actual_parameters_as_formal actuals params) + then + Error.error [ symbol.position ] + "mutually recursive definitions must have the same \ + parameters.\n\ + This is not the case for %s." + (let name1, name2 = (name idx), (name i) in + if name1 <> name2 then name1 ^ " and "^ name2 + else name1) + with _ -> ()) + symbols) (branches i) + in + check_type(); + check_parameters(); + check_producers() + ); + + (* Check that every %type and %on_error_reduce declaration mentions a + well-typed term. *) + List.iter (fun (p, _) -> + check_parameter_type env p + ) p_grammar.p_types; + List.iter (fun (p, _) -> + check_parameter_type env p + ) p_grammar.p_on_error_reduce let rec subst_parameter subst = function | ParameterVar x -> @@ -623,18 +640,18 @@ in (* Process %on_error_reduce declarations. *) - let rec on_error_reduce_from_list (ps : Syntax.parameter list) : StringSet.t = + let rec on_error_reduce_from_list (ps : (Syntax.parameter * 'p) list) : 'p StringMap.t = match ps with | [] -> - StringSet.empty - | nt :: ps -> + StringMap.empty + | (nt, prec) :: ps -> let accu = on_error_reduce_from_list ps in let mangled = mangle nt in - if StringSet.mem mangled accu then + if StringMap.mem mangled accu then Error.error [Parameters.position nt] "there are multiple %%on_error_reduce declarations for nonterminal %s." mangled; - StringSet.add mangled accu + StringMap.add mangled prec accu in let start_symbols = StringMap.domain (p_grammar.p_start_symbols) in diff -Nru menhir-20160526.dfsg/src/parserAux.ml menhir-20160808+dfsg/src/parserAux.ml --- menhir-20160526.dfsg/src/parserAux.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/parserAux.ml 2016-08-08 19:19:04.000000000 +0000 @@ -13,6 +13,11 @@ incr c; ProductionLevel (Error.get_filemark (), !c) +let new_on_error_reduce_level = + new_production_level + (* the counter is shared with [new_production_level], + but this is irrelevant *) + module IdSet = Set.Make (struct type t = identifier located let compare id1 id2 = diff -Nru menhir-20160526.dfsg/src/parserAux.mli menhir-20160808+dfsg/src/parserAux.mli --- menhir-20160526.dfsg/src/parserAux.mli 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/parserAux.mli 2016-08-08 19:19:04.000000000 +0000 @@ -24,6 +24,11 @@ val new_production_level: unit -> branch_production_level +(* [new_on_error_reduce_level()] creates a new level, which is attached to an + [%on_error_reduce] declaration. *) + +val new_on_error_reduce_level: unit -> on_error_reduce_level + (* [check_production_group] accepts a production group and checks that all productions in the group define the same set of identifiers. *) diff -Nru menhir-20160526.dfsg/src/partialGrammar.ml menhir-20160808+dfsg/src/partialGrammar.ml --- menhir-20160526.dfsg/src/partialGrammar.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/partialGrammar.ml 2016-08-08 19:19:04.000000000 +0000 @@ -83,9 +83,9 @@ (* Reductions on error for nonterminals. *) - | DOnErrorReduce (nonterminal) -> + | DOnErrorReduce (nonterminal, prec) -> { grammar with - p_on_error_reduce = nonterminal :: grammar.p_on_error_reduce } + p_on_error_reduce = (nonterminal, prec) :: grammar.p_on_error_reduce } (* Token associativity and precedence. *) @@ -589,24 +589,35 @@ "the type of the start symbol %s is unspecified." nonterminal; ) grammar.p_start_symbols; - (* Every %type definition has, at its head, a nonterminal symbol. *) + (* Every %type definition refers to well-defined (terminal or nonterminal) + symbols and 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, _) = Parameters.unapp p in - if not (StringMap.mem (value head_symb) grammar.p_rules) then - Error.error [Parameters.position p] + + let reserved = [ "error" ] in + + let rec check (kind : string) (must_be_nonterminal : bool) (p : Syntax.parameter) = + (* Destructure head and arguments. *) + let head, ps = Parameters.unapp p in + let head = value head in + (* Check if [head] is a nonterminal or terminal symbol. *) + let is_nonterminal = StringMap.mem head grammar.p_rules + and is_terminal = StringMap.mem head grammar.p_tokens || List.mem head reserved in + (* If [head] is not satisfactory, error. *) + if (must_be_nonterminal && not is_nonterminal) then + Error.error [Parameters.position p] "this should be a nonterminal symbol.\n\ - %s declarations are applicable only to nonterminal symbols." kind - ) ps + %s declarations are applicable only to nonterminal symbols." kind; + if not (is_terminal || is_nonterminal) then + Error.error [Parameters.position p] + "%s is undefined." head; + (* Then, check the arguments. *) + List.iter (check kind false) ps in - check "%type" (List.map fst grammar.p_types); - check "%on_error_reduce" grammar.p_on_error_reduce; + + List.iter (check "%type" true) (List.map fst grammar.p_types); + List.iter (check "%on_error_reduce" true) (List.map fst grammar.p_on_error_reduce); (* Every reference to a symbol is well defined. *) - let reserved = [ "error" ] in let used_tokens = ref StringSet.empty in let mark_token_as_used token = used_tokens := StringSet.add token !used_tokens diff -Nru menhir-20160526.dfsg/src/reachability.ml menhir-20160808+dfsg/src/reachability.ml --- menhir-20160526.dfsg/src/reachability.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/reachability.ml 2016-08-08 19:19:04.000000000 +0000 @@ -35,5 +35,8 @@ "symbol %s is unreachable from any of the start symbol(s)." symbol ) grammar.rules; - { grammar with rules = StringMap.restrict reachable grammar.rules } - + { grammar with + rules = StringMap.restrict reachable grammar.rules; + types = StringMap.restrict reachable grammar.types; + on_error_reduce = StringMap.restrict reachable grammar.on_error_reduce; + } diff -Nru menhir-20160526.dfsg/src/StaticVersion.ml menhir-20160808+dfsg/src/StaticVersion.ml --- menhir-20160526.dfsg/src/StaticVersion.ml 2016-05-26 21:50:28.000000000 +0000 +++ menhir-20160808+dfsg/src/StaticVersion.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1 +1 @@ -let require_20160526 = () +let require_20160808 = () diff -Nru menhir-20160526.dfsg/src/StaticVersion.mli menhir-20160808+dfsg/src/StaticVersion.mli --- menhir-20160526.dfsg/src/StaticVersion.mli 2016-05-26 21:50:28.000000000 +0000 +++ menhir-20160808+dfsg/src/StaticVersion.mli 2016-08-08 19:19:04.000000000 +0000 @@ -1 +1 @@ -val require_20160526 : unit +val require_20160808 : unit diff -Nru menhir-20160526.dfsg/src/syntax.mli menhir-20160808+dfsg/src/syntax.mli --- menhir-20160526.dfsg/src/syntax.mli 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/syntax.mli 2016-08-08 19:19:04.000000000 +0000 @@ -88,6 +88,15 @@ (* ------------------------------------------------------------------------ *) +(* A level is attached to every [%on_error_reduce] declaration. It is used + to decide what to do when several such declarations are applicable in a + single state. *) + +type on_error_reduce_level = + branch_production_level (* we re-use the above type, to save code *) + +(* ------------------------------------------------------------------------ *) + (* A parameter is either just a symbol or an application of a symbol to a nonempty tuple of parameters. Before anonymous rules have been eliminated, it can also be an anonymous rule, represented as a list of branches. *) @@ -167,7 +176,7 @@ (* On-error-reduce declaration. *) - | DOnErrorReduce of parameter + | DOnErrorReduce of parameter * on_error_reduce_level (* ------------------------------------------------------------------------ *) @@ -201,6 +210,6 @@ p_start_symbols : Positions.t StringMap.t; p_types : (parameter * Stretch.ocamltype Positions.located) list; p_tokens : token_properties StringMap.t; - p_on_error_reduce : parameter list; + p_on_error_reduce : (parameter * on_error_reduce_level) list; p_rules : parameterized_rule StringMap.t; } diff -Nru menhir-20160526.dfsg/src/tableBackend.ml menhir-20160808+dfsg/src/tableBackend.ml --- menhir-20160526.dfsg/src/tableBackend.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/tableBackend.ml 2016-08-08 19:19:04.000000000 +0000 @@ -63,9 +63,6 @@ (* The following are names of internal sub-modules. *) -let basics = - "Basics" - let tables = "Tables" @@ -990,16 +987,7 @@ sub-module. This sub-module is used again below, as part of the application of the functor [TableInterpreter.Make]. *) - SIModuleDef (basics, MStruct ( - SIExcDefs [ excdef ] :: - interface_to_structure ( - tokentypedef grammar - ) - )) :: - - SIInclude (MVar basics) :: - - SIValDefs (false, [ excvaldef ]) :: + mbasics grammar @ (* In order to avoid hiding user-defined identifiers, only the exception [Error] and the type [token] should be defined (at @@ -1101,4 +1089,3 @@ Time.tick "Producing abstract syntax" end - diff -Nru menhir-20160526.dfsg/src/unparameterizedSyntax.ml menhir-20160808+dfsg/src/unparameterizedSyntax.ml --- menhir-20160526.dfsg/src/unparameterizedSyntax.ml 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/unparameterizedSyntax.ml 2016-08-08 19:19:04.000000000 +0000 @@ -40,7 +40,7 @@ parameters : Stretch.t list; start_symbols : StringSet.t; types : Stretch.ocamltype StringMap.t; - on_error_reduce : StringSet.t; + on_error_reduce : on_error_reduce_level StringMap.t; tokens : Syntax.token_properties StringMap.t; rules : rule StringMap.t; } @@ -87,4 +87,3 @@ with Not_found -> (* Every start symbol should have a type. *) assert false - diff -Nru menhir-20160526.dfsg/src/version.ml menhir-20160808+dfsg/src/version.ml --- menhir-20160526.dfsg/src/version.ml 2016-05-26 21:50:28.000000000 +0000 +++ menhir-20160808+dfsg/src/version.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1 +1 @@ -let version = "20160526" +let version = "20160808" diff -Nru menhir-20160526.dfsg/src/yacc-parser.mly menhir-20160808+dfsg/src/yacc-parser.mly --- menhir-20160526.dfsg/src/yacc-parser.mly 2016-05-26 21:50:27.000000000 +0000 +++ menhir-20160808+dfsg/src/yacc-parser.mly 2016-08-08 19:19:04.000000000 +0000 @@ -92,7 +92,8 @@ { [ unknown_pos (DParameter $2) ] } | ON_ERROR_REDUCE actuals - { List.map (Positions.map (fun nt -> DOnErrorReduce nt)) + { let prec = ParserAux.new_on_error_reduce_level() in + List.map (Positions.map (fun nt -> DOnErrorReduce (nt, prec))) (List.map Parameters.with_pos $2) } optional_ocamltype: